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

version 1.117, 2002/01/04 20:31:53 version 1.118, 2002/01/05 20:16:17
Line 899  Variable cross-space-dp-orig Line 899  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 , ['] is-forward ,       ghost-list linked <fwd> , 0 , ['] NoExec , what's 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 1052  End-Struct addr-struct Line 1057  End-Struct addr-struct
   dup @ ?dup IF nip EXIT THEN    dup @ ?dup IF nip EXIT THEN
   addr-struct %allocerase tuck swap ! ;    addr-struct %allocerase tuck swap ! ;
   
   >cross
   
 \ Predefined ghosts                                    12dec92py  \ Predefined ghosts                                    12dec92py
   
 Ghost - drop \ need a ghost otherwise "-" would be treated as a number  Ghost - drop \ need a ghost otherwise "-" would be treated as a number
   
 Ghost 0=                                        drop  Ghost 0=                                        drop
 Ghost branch    Ghost ?branch                   2drop  Ghost branch    Ghost ?branch                   2drop
 Ghost (do)      Ghost (?do)                     2drop  
 Ghost (for)                                     drop  
 Ghost (loop)    Ghost (+loop)                   2drop  
 Ghost (next)                                    drop  
 Ghost unloop    Ghost ;S                        2drop  Ghost unloop    Ghost ;S                        2drop
 Ghost lit       Ghost (compile) Ghost !         2drop drop  Ghost lit       Ghost !                         2drop
 Ghost (does>)   Ghost noop                      2drop  Ghost noop                                      drop
 Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop  
 Ghost '                                         drop  
 Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop  Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop
 Ghost :dovar                                    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
 Ghost state drop  
 Ghost call drop  Ghost call drop
 Ghost @ drop  Ghost @ drop
 Ghost useraddr drop  Ghost useraddr drop
 Ghost execute drop  Ghost execute drop
 Ghost + drop  Ghost + drop
 Ghost (C") drop  
 Ghost decimal drop  Ghost decimal drop
 Ghost hex drop  Ghost hex drop
   Ghost lit@ drop
   Ghost lit-perform drop
   Ghost lit+ drop
   Ghost does-exec drop
   
 \ \ Parameter for target systems                         06oct92py  \ \ Parameter for target systems                         06oct92py
   
   
 >cross  
 \ we define it ans like...  \ we define it ans like...
 wordlist Constant target-environment  wordlist Constant target-environment
   
Line 1637  T has? relocate H Line 1639  T has? relocate H
 : A!                    swap >address swap dup relon T ! H ;  : A!                    swap >address swap dup relon T ! H ;
 : A,    ( w -- )        >address T here H relon T , H ;  : A,    ( w -- )        >address T here H relon T , H ;
   
   \ high-level ghosts
   
   >CROSS
   
   : call-forward ( ghost -- )
       there 0 colon, 0 do-refered ;
   ' call-forward IS is-forward
   
   Ghost (do)      Ghost (?do)                     2drop
   Ghost (for)                                     drop
   Ghost (loop)    Ghost (+loop)                   2drop
   Ghost (next)                                    drop
   Ghost (does>)   Ghost (compile)                 2drop
   Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
   Ghost (C")                                      drop
   Ghost '                                         drop
   
   \ ' prim-forward IS is-forward
   
   \ user ghosts
   
   Ghost state drop
   
 \ \ --------------------        Host/Target copy etc.           29aug01jaw  \ \ --------------------        Host/Target copy etc.           29aug01jaw
   
Line 1698  previous Line 1722  previous
 : (xt) T a, H ;                                 ' (xt) plugin-of xt,  : (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 xt, comp[ tempdp> ;        ' (cr) plugin-of colon-resolve  : (cr) >tempdp colon, 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 1736  previous Line 1760  previous
     loadfile ,       loadfile , 
     sourceline# ,       sourceline# , 
     space>      space>
   ;  ;
   
   ' (refered) IS do-refered
   
 : refered ( ghost tag -- )  : refered ( ghost tag -- )
 \G creates a resolve structure  \G creates a resolve structure
Line 1800  Defer resolve-warning Line 1826  Defer resolve-warning
 : prim-resolved  ( ghost -- )  : prim-resolved  ( ghost -- )
     >link @ prim, ;      >link @ prim, ;
   
 \ FIXME: not used currently  0 Value resolved
 : does-resolved ( ghost -- )  
     dup g>body alit, >do:ghost @ g>xt 0 t>body - colon, ;  
   
 : (is-forward)   ( ghost -- )  
   colonmark, 0 (refered) ; \ compile space for call  
 ' (is-forward) IS is-forward  
   
 : resolve  ( ghost tcfa -- )  : resolve  ( ghost tcfa -- )
 \G resolve referencies to ghost with tcfa  \G resolve referencies to ghost with tcfa
Line 1827  Defer resolve-warning Line 1847  Defer resolve-warning
     swap >r r@ >link @ swap \ ( list tcfa R: ghost )      swap >r r@ >link @ swap \ ( list tcfa R: ghost )
     \ mark ghost as resolved      \ mark ghost as resolved
     dup r@ >link ! <res> r@ >magic !      dup r@ >link ! <res> r@ >magic !
     r@ >comp @ ['] is-forward = IF      r@ to resolved
       r@ >comp @ ['] prim-forward = IF
           ['] prim-resolved  r@ >comp !  THEN
       r@ >comp @ what's is-forward = IF
         ['] prim-resolved  r@ >comp !  THEN          ['] prim-resolved  r@ >comp !  THEN
     \ loop through forward referencies      \ loop through forward referencies
     r> -rot       r> -rot 
Line 2176  Variable prim# Line 2199  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 )
   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 2458  Cond: ; ( -- ) Line 2483  Cond: ; ( -- )
         fini,          fini,
         comp[          comp[
         ;Resolve @           ;Resolve @ 
         IF      ;Resolve @ ;Resolve cell+ @ resolve           IF  ['] colon-resolved ;Resolve @ >comp !
                 ['] colon-resolved ;Resolve @ >comp !              ;Resolve @ ;Resolve cell+ @ resolve 
         THEN          THEN
         interpreting-state          interpreting-state
         ;Cond          ;Cond
Line 2478  Cond: [ ( -- ) interpreting-state ;Cond Line 2503  Cond: [ ( -- ) interpreting-state ;Cond
   
 Defer instant-interpret-does>-hook  Defer instant-interpret-does>-hook
   
   : does-resolved ( ghost -- )
       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
   Last-Header-Ghost @ >do:ghost @ ?dup     Last-Header-Ghost @ >do:ghost @ ?dup 
Line 2489  Cond: DOES> Line 2518  Cond: DOES>
         resolve-does>-part          resolve-does>-part
         ;Cond          ;Cond
   
 : DOES> switchrom doeshandler, T here H !does   : DOES>
   ['] does-resolved created >comp !      ['] does-resolved created >comp !
   instant-interpret-does>-hook      switchrom doeshandler, T here H !does 
   depth T ] H ;      instant-interpret-does>-hook
       depth T ] H ;
   
 >CROSS  >CROSS
 \ Creation                                              01nov92py  \ Creation                                              01nov92py
Line 2538  Cond: DOES> Line 2568  Cond: DOES>
    2dup >exec @ swap >exec2 !      2dup >exec @ swap >exec2 ! 
    >comp @ swap >comp ! ;     >comp @ swap >comp ! ;
   
   0 Value createhere
   
   : create-resolve ( -- )
       created createhere resolve 0 ;Resolve ! ;
   : create-resolve-immediate ( -- )
       create-resolve T immediate H ;
   
 : TCreate ( <name> -- )  : TCreate ( <name> -- )
   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 to created    dup >created on  dup to created
   2dup takeover-x-semantics hereresolve gdoes, ;    2dup takeover-x-semantics
     there to createhere drop gdoes, ;
   
 : RTCreate ( <name> -- )  : RTCreate ( <name> -- )
 \ creates a new word with code-field in ram  \ creates a new word with code-field in ram
Line 2551  Cond: DOES> Line 2589  Cond: DOES>
   IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
   \ make Alias    \ make Alias
   executed-ghost @ (THeader     executed-ghost @ (THeader 
   dup >created on    dup >created on  dup to created
   2dup takeover-x-semantics    2dup takeover-x-semantics
   there 0 T a, H alias-mask flag!    there 0 T a, H alias-mask flag!
   \ store poiter to code-field    \ store poiter to code-field
   switchram T cfalign H    switchram T cfalign H
   there swap T ! H    there swap T ! H
   there tlastcfa !     there tlastcfa ! 
   hereresolve gdoes, ;    there to createhere drop gdoes, ;
   
 : Build:  ( -- [xt] [colon-sys] )  : Build:  ( -- [xt] [colon-sys] )
   :noname postpone TCreate ;    :noname postpone TCreate ;
Line 2572  Cond: DOES> Line 2610  Cond: DOES>
   [ [THEN] ] ;    [ [THEN] ] ;
   
 : ;Build  : ;Build
   postpone ; built >exec ! ; immediate    postpone create-resolve postpone ; built >exec ! ; immediate
   
   : ;Build-immediate
       postpone create-resolve-immediate
       postpone ; built >exec ! ; immediate
   
 : gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
   executed-ghost @ g>body ;    executed-ghost @ g>body ;
Line 2697  BuildSmart:  ( -- ) [T'] noop T A, H ;Bu Line 2739  BuildSmart:  ( -- ) [T'] noop T A, H ;Bu
 by: :dodefer ( ghost -- ) X @ texecute ;DO  by: :dodefer ( ghost -- ) X @ texecute ;DO
   
 Builder interpret/compile:  Builder interpret/compile:
 Build: ( inter comp -- ) swap T immediate A, A, H ;Build  Build: ( inter comp -- ) swap T A, A, H ;Build-immediate
 DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
   
 \ Sturctures                                           23feb95py  \ Sturctures                                           23feb95py
Line 2750  DO:  abort" Not in cross mode" ;DO Line 2792  DO:  abort" Not in cross mode" ;DO
 T has? peephole H [IF]  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,
   : (call-res) >tempdp resolved gexecute tempdp> drop ;
                                                   ' (call-res) plugin-of colon-resolve
 : (prim) dup 0< IF  ( $4000 - ) ELSE  : (prim) dup 0< IF  ( $4000 - ) ELSE
     ." wrong usage of (prim) "      ." wrong usage of (prim) "
     dup gdiscover IF  .ghost  ELSE  .  THEN  cr -2 throw  THEN      dup gdiscover IF  .ghost  ELSE  .  THEN  cr -2 throw  THEN
Line 2762  T has? peephole H [IF] Line 2807  T has? peephole H [IF]
 \ compile: g>body X @ lit, ;compile  \ compile: g>body X @ lit, ;compile
   
 Builder (Constant)  Builder (Constant)
 compile: g>body alit, compile @ ;compile  compile: g>body compile lit@ T a, H ;compile
   
 Builder (Value)  Builder (Value)
 compile: g>body alit, compile @ ;compile  compile: g>body compile lit@ T a, H ;compile
   
 \ this changes also Variable, AVariable and 2Variable  \ this changes also Variable, AVariable and 2Variable
 Builder Create  Builder Create
Line 2775  Builder User Line 2820  Builder User
 compile: g>body compile useraddr T @ , H ;compile  compile: g>body compile useraddr T @ , H ;compile
   
 Builder Defer  Builder Defer
 compile: g>body alit, compile @ compile execute ;compile  compile: g>body compile lit-perform T A, H ;compile
   
 Builder (Field)  Builder (Field)
 compile: g>body T @ H lit, compile + ;compile  compile: g>body T @ H compile lit+ T , H ;compile
   
 Builder interpret/compile:  Builder interpret/compile:
 compile: does-resolved ;compile  compile: does-resolved ;compile

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


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