Diff for /gforth/cross.fs between versions 1.115 and 1.119

version 1.115, 2001/09/16 10:21:13 version 1.119, 2002/01/05 22:58:59
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 898  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, 0 do-refered ; \ compile space for call
   : doer-forward   ( ghost -- )
     colonmark, 2 do-refered ; \ compile space for doer
   ' 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 1051  End-Struct addr-struct Line 1059  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 :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
   
   ' doer-forward IS is-forward
   
   Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop
   Ghost :dovar                                    drop
   
   ' prim-forward IS is-forward
   
 \ \ 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 1636  T has? relocate H Line 1646  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 1694  previous Line 1726  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 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 1708  previous Line 1741  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 1734  previous Line 1767  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 1798  Defer resolve-warning Line 1833  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>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 1825  Defer resolve-warning Line 1854  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 1964  Variable to-doc  to-doc on Line 1996  Variable to-doc  to-doc on
 \ Target TAGS creation  \ Target TAGS creation
   
 s" kernel.TAGS" r/w create-file throw value tag-file-id  s" kernel.TAGS" r/w create-file throw value tag-file-id
   s" kernel.tags" r/w create-file throw value vi-tag-file-id
 \ contains the file-id of the tags file  \ contains the file-id of the tags file
   
 Create tag-beg 2 c,  7F c, bl c,  Create tag-beg 2 c,  7F c, bl c,
 Create tag-end 2 c,  bl c, 01 c,  Create tag-end 2 c,  bl c, 01 c,
 Create tag-bof 1 c,  0C c,  Create tag-bof 1 c,  0C c,
   Create tag-tab 1 c,  09 c,
   
 2variable last-loadfilename 0 0 last-loadfilename 2!  2variable last-loadfilename 0 0 last-loadfilename 2!
                           
Line 1982  Create tag-bof 1 c,  0C c, Line 2016  Create tag-bof 1 c,  0C c,
         s" ,0" tag-file-id write-line throw          s" ,0" tag-file-id write-line throw
     THEN ;      THEN ;
   
 : cross-tag-entry  ( -- )  : cross-gnu-tag-entry  ( -- )
     tlast @ 0<> \ not an anonymous (i.e. noname) header      tlast @ 0<> \ not an anonymous (i.e. noname) header
     IF      IF
         put-load-file-name          put-load-file-name
         source >in @ min tag-file-id write-file throw          source >in @ min tag-file-id write-file throw
         tag-beg count tag-file-id write-file throw          tag-beg count tag-file-id write-file throw
         tlast @ >image count 1F and tag-file-id write-file throw          Last-Header-Ghost @ >ghostname tag-file-id write-file throw
         tag-end count tag-file-id write-file throw          tag-end count tag-file-id write-file throw
         base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw          base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw
 \       >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw  \       >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
Line 1996  Create tag-bof 1 c,  0C c, Line 2030  Create tag-bof 1 c,  0C c,
         base !          base !
     THEN ;      THEN ;
   
   : cross-vi-tag-entry ( -- )
       tlast @ 0<> \ not an anonymous (i.e. noname) header
       IF
           sourcefilename vi-tag-file-id write-file throw
           tag-tab count vi-tag-file-id write-file throw
           Last-Header-Ghost @ >ghostname vi-tag-file-id write-file throw
           tag-tab count vi-tag-file-id write-file throw
           s" /^" vi-tag-file-id write-file throw
           source vi-tag-file-id write-file throw
           s" $/" vi-tag-file-id write-line throw
       THEN ;
   
   : cross-tag-entry ( -- )
       cross-gnu-tag-entry
       cross-vi-tag-entry ;
   
 \ Check for words  \ Check for words
   
 Defer skip? ' false IS skip?  Defer skip? ' false IS skip?
Line 2104  Variable aprim-nr -20 aprim-nr ! Line 2154  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 2139  Defer setup-prim-semantics Line 2190  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# ! ;
 : 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 2241  T 2 cells H Value xt>body Line 2293  T 2 cells H Value xt>body
   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 2437  Cond: ; ( -- ) Line 2489  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 2447  Cond: [ ( -- ) interpreting-state ;Cond Line 2499  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
   
   : does-resolved ( ghost -- )
       compile does-exec g>xt T a, H ;
   
 : 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 2474  Cond: DOES> Line 2523  Cond: DOES>
         resolve-does>-part          resolve-does>-part
         ;Cond          ;Cond
   
 : DOES> switchrom doeshandler, T here H !does   : DOES>
   instant-interpret-does>-hook      ['] does-resolved created >comp !
   depth T ] H ;      switchrom doeshandler, T here H !does 
       instant-interpret-does>-hook
       depth T ] H ;
   
 >CROSS  >CROSS
 \ Creation                                              01nov92py  \ Creation                                              01nov92py
Line 2494  Cond: DOES> Line 2545  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 2514  Cond: DOES> Line 2564  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 2523  Cond: DOES> Line 2573  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 >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 2536  Cond: DOES> Line 2594  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 2557  Cond: DOES> Line 2615  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 2682  BuildSmart:  ( -- ) [T'] noop T A, H ;Bu Line 2744  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 2735  DO:  abort" Not in cross mode" ;DO Line 2797  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
       ." 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 2743  T has? peephole H [IF] Line 2812  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
 \ 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
   
 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:
   compile: does-resolved ;compile
   
   Builder input-method
   compile: does-resolved ;compile
   
   Builder input-var
   compile: does-resolved ;compile
   
 [THEN]  [THEN]
   

Removed from v.1.115  
changed lines
  Added in v.1.119


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