[gforth] / gforth / cross.fs  

gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.104 and 1.105

version 1.104, Tue Sep 4 13:07:44 2001 UTC version 1.105, Wed Sep 5 09:42:38 2001 UTC
Line 62 
Line 62 
 : T  previous Ghosts also Target ; immediate  : T  previous Ghosts also Target ; immediate
 : G  Ghosts ; immediate  : G  Ghosts ; immediate
   
   
 : >cross  also Cross definitions previous ;  : >cross  also Cross definitions previous ;
 : >target also Target definitions previous ;  : >target also Target definitions previous ;
 : >minimal also Minimal definitions previous ;  : >minimal also Minimal definitions previous ;
Line 251 
Line 252 
         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
           IF      state @ IF compile,
                   ELSE execute THEN
           ELSE    -1 ABORT" Cross: access method not supported!"
           THEN ; immediate
   
 \ Begin CROSS COMPILER:  \ Begin CROSS COMPILER:
   
 \ debugging  \ debugging
Line 628 
Line 635 
 : defempty? ; immediate  : defempty? ; immediate
 [THEN]  [THEN]
   
   \ \ --------------------        Compiler Plug Ins               01aug97jaw
   
   >CROSS
   
   \ Compiler States
   
   Variable comp-state
   0 Constant interpreting
   1 Constant compiling
   2 Constant resolving
   3 Constant assembling
   
   : compiling? comp-state @ compiling = ;
   
   : pi-undefined -1 ABORT" Plugin undefined" ;
   
   : Plugin ( -- : pluginname )
     Create
     \ for normal cross-compiling only one action
     \ exists, this fields are identical. For the instant
     \ simulation environment we need, two actions for each plugin
     \ the target one and the one that generates the simulation code
     ['] pi-undefined , \ action
     ['] pi-undefined , \ target plugin action
     8765 ,     \ plugin magic
     DOES> perform ;
   
   Plugin DummyPlugin
   
   : 'PI ( -- addr : pluginname )
     ' >body dup 2 cells + @ 8765 <> ABORT" not a plugin" ;
   
   : plugin-of ( xt -- : pluginname )
     dup 'PI 2! ;
   
   : action-of ( xt -- : plunginname )
     'PI cell+ ! ;
   
   : TPA ( -- : plugin )
   \ target plugin action
   \ executes current target action of plugin
     'PI cell+ POSTPONE literal POSTPONE perform ; immediate
   
   Variable ppi-temp 0 ppi-temp !
   
   : pa:
   \g define plugin action
     ppi-temp @ ABORT" pa: definition not closed"
     'PI ppi-temp ! :noname ;
   
   : ;pa
   \g end a definition for plugin action
     POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate
   
   
   Plugin lit, ( n -- )
   Plugin alit, ( n -- )
   
   Plugin branch, ( target-addr -- )       \ compiles a branch
   Plugin ?branch, ( target-addr -- )      \ compiles a ?branch
   Plugin branchmark, ( -- branch-addr )   \ reserves room for a branch
   Plugin ?branchmark, ( -- branch-addr )  \ reserves room for a ?branch
   Plugin ?domark, ( -- branch-addr )      \ reserves room for a ?do branch
   Plugin branchto, ( -- )                 \ actual program position is target of a branch (do e.g. alignment)
   ' NOOP plugin-of branchto,
   Plugin branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
   Plugin branchtomark, ( -- target-addr ) \ marks a branch destination
   
   Plugin colon, ( tcfa -- )               \ compiles call to tcfa at current position
   Plugin prim, ( tcfa -- )                \ compiles primitive invocation
   Plugin colonmark, ( -- addr )           \ marks a colon call
   Plugin colon-resolve ( tcfa addr -- )
   
   Plugin addr-resolve ( target-addr addr -- )
   Plugin doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )
   
   Plugin ncontrols? ( [ xn ... x1 ] n -- ) \ checks wheter n control structures are open
   Plugin if,      ( -- if-token )
   Plugin else,    ( if-token -- if-token )
   Plugin then,    ( if-token -- )
   Plugin ahead,
   Plugin begin,
   Plugin while,
   Plugin until,
   Plugin again,
   Plugin repeat,
   Plugin cs-swap  ( x1 x2 -- x2 x1 )
   
   Plugin case,    ( -- n )
   Plugin of,      ( n -- x1 n )
   Plugin endof,   ( x1 n -- x2 n )
   Plugin endcase, ( x1 .. xn n -- )
   
   Plugin do,      ( -- do-token )
   Plugin ?do,     ( -- ?do-token )
   Plugin for,     ( -- for-token )
   Plugin loop,    ( do-token / ?do-token -- )
   Plugin +loop,   ( do-token / ?do-token -- )
   Plugin next,    ( for-token )
   Plugin leave,   ( -- )
   Plugin ?leave,  ( -- )
   
   [IFUNDEF] ca>native
   Plugin ca>native
   [THEN]
   
   Plugin doprim,  \ compiles start of a primitive
   Plugin docol,           \ compiles start of a colon definition
   Plugin doer,
   Plugin fini,      \ compiles end of definition ;s
   Plugin doeshandler,
   Plugin dodoes,
   
   Plugin colon-start
   ' noop plugin-of colon-start
   Plugin colon-end
   ' noop plugin-of colon-end
   
   Plugin ]comp     \ starts compilation
   ' noop plugin-of ]comp
   Plugin comp[     \ ends compilation
   ' noop plugin-of comp[
   
   Plugin t>body             \ we need the system >body
                           \ and the target >body
   
   >TARGET
   : >body t>body ;
   
   
 \ Ghost Builder                                        06oct92py  \ Ghost Builder                                        06oct92py
   
   >CROSS
 hex  hex
   \ Values for ghost magic
 4711 Constant <fwd>             4712 Constant <res>  4711 Constant <fwd>             4712 Constant <res>
 4713 Constant <imm>             4714 Constant <do:>  4713 Constant <imm>             4714 Constant <do:>
 4715 Constant <skip>  4715 Constant <skip>
   
   \ Bitmask for ghost flags
 1 Constant <unique>  1 Constant <unique>
   2 Constant <primitive>
   
   \ FXIME: move this to general stuff?
   : set-flag ( addr flag -- )
     over @ or swap ! ;
   
   : reset-flag ( addr flag -- )
     invert over @ and swap ! ;
   
   : get-flag ( addr flag -- f )
     swap @ and 0<> ;
   
   
 Struct  Struct
   
Line 652 
Line 804 
   \ execution symantics (while target compiling) of ghost    \ execution symantics (while target compiling) of ghost
   cell% field >exec    cell% field >exec
   
     cell% field >comp
   
   cell% field >exec-compile    cell% field >exec-compile
   
   cell% field >exec2    cell% field >exec2
Line 722 
Line 876 
   ELSE true ABORT" CROSS: Don't execute ghost, or immediate target word"    ELSE true ABORT" CROSS: Don't execute ghost, or immediate target word"
   THEN ;    THEN ;
   
   Defer is-forward
   
 : (ghostheader) ( -- )  : (ghostheader) ( -- )
   ghost-list linked <fwd> , 0 , ['] NoExec , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;    ghost-list linked <fwd> , 0 , ['] NoExec , ['] is-forward ,
     0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;
   
 : ghostheader ( -- ) (ghostheader) 0 , ;  : ghostheader ( -- ) (ghostheader) 0 , ;
   
Line 783 
Line 940 
   REPEAT    REPEAT
   drop r> false ;    drop r> false ;
   
   : xt>ghost ( xt -- ghost )
     gdiscover 0= ABORT" CROSS: ghost not found for this xt" ;
   
 : Ghost   ( "name" -- ghost )  : Ghost   ( "name" -- ghost )
   >in @ bl word gfind IF  nip EXIT  THEN    >in @ bl word gfind IF  nip EXIT  THEN
   drop  >in !  Make-Ghost ;    drop  >in !  Make-Ghost ;
Line 841 
Line 1001 
 \  bl word gfind 0= ABORT" CROSS: Ghost don't exists"  \  bl word gfind 0= ABORT" CROSS: Ghost don't exists"
   ghost state @ IF postpone literal THEN ; immediate    ghost state @ IF postpone literal THEN ; immediate
   
 : ghost>cfa ( ghost -- cfa )  : g>xt ( ghost -- xt )
   \G Returns the xt (cfa) of a ghost. Issues a warning if undefined.
   dup undefined? ABORT" CROSS: forward " >link @ ;    dup undefined? ABORT" CROSS: forward " >link @ ;
   
   : g>body ( ghost -- body )
   \G Returns the body-address (pfa) of a ghost.
   \G Issues a warning if undefined (a forward-reference).
     g>xt X >body ;
   
 1 Constant <label>  1 Constant <label>
   
 Struct  Struct
Line 951 
Line 1117 
 false DefaultValue hash  false DefaultValue hash
 false DefaultValue xconds  false DefaultValue xconds
 false DefaultValue header  false DefaultValue header
   false DefaultValue backtrace
   false DefaultValue new-input
   false DefaultValue peephole
 [THEN]  [THEN]
   
 true DefaultValue interpreter  true DefaultValue interpreter
Line 1022 
Line 1191 
 : target>bitmask-size ( u1 -- u2 )  : target>bitmask-size ( u1 -- u2 )
   1- tcell>bit rshift 1+ ;    1- tcell>bit rshift 1+ ;
   
 : allocatetarget ( size --- adr )  : allocatetarget ( size -- adr )
   dup allocate ABORT" CROSS: No memory for target"    dup allocate ABORT" CROSS: No memory for target"
   swap over swap erase ;    swap over swap erase ;
   
Line 1134 
Line 1303 
 ' dictionary ALIAS rom-dictionary  ' dictionary ALIAS rom-dictionary
   
   
 : setup-target ( -- )   \G initialize targets memory space  : setup-target ( -- )   \G initialize target's memory space
   s" rom" T $has? H    s" rom" T $has? H
   IF  \ check for ram and rom...    IF  \ check for ram and rom...
       \ address-space area nip 0<>        \ address-space area nip 0<>
Line 1174 
Line 1343 
         ELSE    r> drop THEN          ELSE    r> drop THEN
    REPEAT drop ;     REPEAT drop ;
   
 \ MakeKernal                                                    22feb99jaw  \ MakeKernel                                                    22feb99jaw
   
 : makekernel ( targetsize -- targetsize )  : makekernel ( targetsize -- targetsize )
   dup dictionary >rlen ! setup-target ;    dup dictionary >rlen ! setup-target ;
Line 1441 
Line 1610 
 >TARGET  >TARGET
 H also Forth definitions  H also Forth definitions
   
 : X     bl word count [ ' target >wordlist ] Literal search-wordlist  \ FIXME: should we include the assembler really in the forth
         IF      state @ IF compile,  \ dictionary?!?!?!? This conflicts with the existing assembler
                 ELSE execute THEN  \ of the host forth system!!
         ELSE    -1 ABORT" Cross: access method not supported!"  
         THEN ; immediate  
   
 [IFDEF] asm-include asm-include [THEN] hex  [IFDEF] asm-include asm-include [THEN] hex
   
 previous  previous
Line 1479 
Line 1645 
 : on            T -1 swap ! H ;  : on            T -1 swap ! H ;
 : off           T 0 swap ! H ;  : off           T 0 swap ! H ;
   
 \ \ --------------------        Compiler Plug Ins               01aug97jaw  
   
 >CROSS  
   
 \  Compiler States  
   
 Variable comp-state  
 0 Constant interpreting  
 1 Constant compiling  
 2 Constant resolving  
 3 Constant assembling  
   
 : compiling? comp-state @ compiling = ;  
   
 : Plugin ( -- : pluginname )  
   Create  
   ['] noop , \ action  
   ['] noop , \ target plugin action  
   8765 ,     \ plugin magic  
   DOES> perform ;  
   
 Plugin DummyPlugin  
   
 : 'PI ( -- addr : pluginname )  
   ' >body dup 2 cells + @ 8765 <> ABORT" not a plugin" ;  
   
 : plugin-of ( xt -- : pluginname )  
   dup 'PI 2! ;  
   
 : action-of ( xt -- : plunginname )  
   'PI cell+ ! ;  
   
 : TPA ( -- : plugin )  
 \ target plugin action  
 \ executes current target action of plugin  
   'PI cell+ POSTPONE literal POSTPONE perform ; immediate  
   
 Variable ppi-temp 0 ppi-temp !  
   
 : pa:  
 \g define plugin action  
   ppi-temp @ ABORT" pa: definition not closed"  
   'PI ppi-temp ! :noname ;  
   
 : ;pa  
 \g end a definition for plugin action  
   POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate  
   
   
 Plugin lit, ( n -- )  
 Plugin alit, ( n -- )  
   
 Plugin branch, ( target-addr -- )       \ compiles a branch  
 Plugin ?branch, ( target-addr -- )      \ compiles a ?branch  
 Plugin branchmark, ( -- branch-addr )   \ reserves room for a branch  
 Plugin ?branchmark, ( -- branch-addr )  \ reserves room for a ?branch  
 Plugin ?domark, ( -- branch-addr )      \ reserves room for a ?do branch  
 Plugin branchto, ( -- )                 \ actual program position is target of a branch (do e.g. alignment)  
 Plugin branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark  
 Plugin branchtomark, ( -- target-addr ) \ marks a branch destination  
   
 Plugin colon, ( tcfa -- )               \ compiles call to tcfa at current position  
 Plugin colonmark, ( -- addr )           \ marks a colon call  
 Plugin colon-resolve ( tcfa addr -- )  
   
 Plugin addr-resolve ( target-addr addr -- )  
 Plugin doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )  
   
 Plugin ncontrols? ( [ xn ... x1 ] n -- ) \ checks wheter n control structures are open  
 Plugin if,      ( -- if-token )  
 Plugin else,    ( if-token -- if-token )  
 Plugin then,    ( if-token -- )  
 Plugin ahead,  
 Plugin begin,  
 Plugin while,  
 Plugin until,  
 Plugin again,  
 Plugin repeat,  
 Plugin cs-swap  ( x1 x2 -- x2 x1 )  
   
 Plugin case,    ( -- n )  
 Plugin of,      ( n -- x1 n )  
 Plugin endof,   ( x1 n -- x2 n )  
 Plugin endcase, ( x1 .. xn n -- )  
   
 Plugin do,      ( -- do-token )  
 Plugin ?do,     ( -- ?do-token )  
 Plugin for,     ( -- for-token )  
 Plugin loop,    ( do-token / ?do-token -- )  
 Plugin +loop,   ( do-token / ?do-token -- )  
 Plugin next,    ( for-token )  
 Plugin leave,   ( -- )  
 Plugin ?leave,  ( -- )  
   
 [IFUNDEF] ca>native  
 Plugin ca>native  
 [THEN]  
   
 Plugin doprim,  \ compiles start of a primitive  
 Plugin docol,           \ compiles start of a colon definition  
 Plugin doer,  
 Plugin fini,      \ compiles end of definition ;s  
 Plugin doeshandler,  
 Plugin dodoes,  
   
 Plugin colon-start  
 Plugin colon-end  
   
 Plugin ]comp     \ starts compilation  
 Plugin comp[     \ ends compilation  
   
 T 2 cells H Value xt>body  
   
 Plugin t>body             \ we need the system >body  
                         \ and the target >body  
   
 >TARGET  
 : >body t>body ;  
 >CROSS  >CROSS
   
 : (cc) T a, H ;                                 ' (cc) plugin-of colon,  : (cc) T a, H ;                                 ' (cc) plugin-of colon,
   : (prim) T a, H ;                               ' (prim) plugin-of prim,
   
 : (cr) >tempdp ]comp colon, comp[ tempdp> ;     ' (cr) plugin-of colon-resolve  : (cr) >tempdp ]comp prim, 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 1616 
Line 1665 
     -1 colon, ;                                 ' (cm) plugin-of colonmark,      -1 colon, ;                                 ' (cm) plugin-of colonmark,
   
 >TARGET  >TARGET
 : compile, colon, ;  : compile, ( xt -- )
     dup xt>ghost >ghost-flags <primitive> get-flag
     IF prim, ELSE colon, THEN ;
 >CROSS  >CROSS
   
 \ resolve structure  \ resolve structure
Line 1696 
Line 1747 
   swap exists-warning    swap exists-warning
   >link ! ;    >link ! ;
   
 Variable rdbg  : colon-resolved   ( ghost -- )
       >link @ colon, ; \ compile-call
   
   : prim-resolved  ( ghost -- )
       >link @ prim, ;
   
   \ FIXME: not activated
   : 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
     rdbg @ IF break: THEN  
     dup taddr>region 0<> IF      dup taddr>region 0<> IF
       2dup (>regiontype) define-addr-struct addr-xt-ghost        2dup (>regiontype) define-addr-struct addr-xt-ghost
   
       \ we define new address only if empty        \ we define new address only if empty
       \ this is for not to overtake the alias ghost        \ this is for not to take over the alias ghost
         \ (different ghost, but identical xt)
       \ but the very first that really defines it        \ but the very first that really defines it
 \ FIXME: define when HeaderGhost is ready  
       dup @ 0= IF ! ELSE 2drop THEN        dup @ 0= IF ! ELSE 2drop THEN
 \    !  
     THEN      THEN
   
     \ is ghost resolved?, second resolve means another      \ is ghost resolved?, second resolve means another
Line 1719 
Line 1780 
     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
           ['] prim-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 1730 
Line 1793 
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
 : is-forward   ( ghost -- )  \ FIXME cleanup
   colonmark, 0 (refered) ; \ compile space for call  \ : is-resolved   ( ghost -- )
   \  >link @ colon, ; \ compile-call
 : is-resolved   ( ghost -- )  
   >link @ colon, ; \ compile-call  
   
 : (gexecute)   ( ghost -- )  : (gexecute)   ( ghost -- )
   dup >magic @    dup >comp @ EXECUTE ;
   <fwd> = IF  is-forward  ELSE  is-resolved  THEN ;  
   
 : gexecute ( ghost -- )  : gexecute ( ghost -- )
 \  dup >magic @ <imm> = IF -1 ABORT" CROSS: gexecute on immediate word" THEN    dup >magic @ <imm> = IF -1 ABORT" CROSS: gexecute on immediate word" THEN
   (gexecute) ;    (gexecute) ;
   
 : addr,  ( ghost -- )  : addr,  ( ghost -- )
   dup >magic @ <fwd> = IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;    dup forward? IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;
   
 \ !! : ghost,     ghost  gexecute ;  \ !! : ghost,     ghost  gexecute ;
   
Line 1807 
Line 1867 
   
 VARIABLE ^imm  VARIABLE ^imm
   
   \ !! should be target wordsize specific
   $80 constant alias-mask
   $40 constant immediate-mask
   $20 constant restrict-mask
   
 >TARGET  >TARGET
 : immediate     40 flag!  : immediate     immediate-mask flag!
                 ^imm @ @ dup <imm> = IF  drop  EXIT  THEN                  ^imm @ @ dup <imm> = IF  drop  EXIT  THEN
                 <res> <> ABORT" CROSS: Cannot immediate a unresolved word"                  <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
                 <imm> ^imm @ ! ;                  <imm> ^imm @ ! ;
 : restrict      20 flag! ;  : restrict      restrict-mask flag! ;
   
 : isdoer  : isdoer
 \G define a forth word as doer, this makes obviously only sence on  \G define a forth word as doer, this makes obviously only sence on
Line 1847 
Line 1912 
         s" " doc-file-id write-line throw          s" " doc-file-id write-line throw
         s" make-doc " doc-file-id write-file throw          s" make-doc " doc-file-id write-file throw
   
         tlast @ >image count 1F and doc-file-id write-file throw          Last-Header-Ghost @ >ghostname doc-file-id write-file throw
         >in @          >in @
         [char] ( parse 2drop          [char] ( parse 2drop
         [char] ) parse doc-file-id write-file throw          [char] ) parse doc-file-id write-file throw
Line 1980 
Line 2045 
     [ [THEN] ]      [ [THEN] ]
     dup Last-Header-Ghost ! dup to lastghost      dup Last-Header-Ghost ! dup to lastghost
     dup >magic ^imm !     \ a pointer for immediate      dup >magic ^imm !     \ a pointer for immediate
     80 flag!      alias-mask flag!
     cross-doc-entry cross-tag-entry      cross-doc-entry cross-tag-entry
     setup-execution-semantics      setup-execution-semantics
     ;      ;
Line 2011 
Line 2076 
 : Alias    ( cfa -- ) \ name  : Alias    ( cfa -- ) \ name
   >in @ skip? IF  2drop  EXIT  THEN  >in !    >in @ skip? IF  2drop  EXIT  THEN  >in !
   (THeader ( S xt ghost )    (THeader ( S xt ghost )
   2dup swap gdiscover 0= ABORT" missing" swap copy-execution-semantics    2dup swap xt>ghost swap copy-execution-semantics
   over resolve T A, H 80 flag! ;    over resolve T A, H alias-mask flag! ;
   
 Variable last-prim-ghost  Variable last-prim-ghost
 0 last-prim-ghost !  0 last-prim-ghost !
Line 2052 
Line 2117 
      .sourcepos ." needs prim: " >in @ bl word count type >in ! cr       .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
   THEN    THEN
   prim# @ (THeader ( S xt ghost )    prim# @ (THeader ( S xt ghost )
   over resolve T A, H 80 flag!    dup >ghost-flags <primitive> set-flag
     over resolve T A, H alias-mask flag!
   -1 prim# +! ;    -1 prim# +! ;
 >CROSS  >CROSS
   
Line 2097 
Line 2163 
   
 >TARGET  >TARGET
   
 : '  ( -- cfa )  : '  ( -- xt )
 \ returns the target-cfa of a ghost  \G returns the target-cfa of a ghost
   bl word gfind 0= ABORT" CROSS: Ghost don't exists"    bl word gfind 0= ABORT" CROSS: Ghost don't exists"
   ghost>cfa ;    g>xt ;
   
 \ FIXME: this works for the current use cases, but is not  \ FIXME: this works for the current use cases, but is not
 \ in all cases correct ;-)  \ in all cases correct ;-)
Line 2112 
Line 2178 
   
 : [T']  : [T']
 \ returns the target-cfa of a ghost, or compiles it as literal  \ returns the target-cfa of a ghost, or compiles it as literal
   postpone [G'] state @ IF postpone ghost>cfa ELSE ghost>cfa THEN ; immediate    postpone [G'] state @ IF postpone g>xt ELSE g>xt THEN ; immediate
   
 \ \ threading modell                                    13dec92py  \ \ threading modell                                    13dec92py
 \ modularized                                           14jun97jaw  \ modularized                                           14jun97jaw
   
 : fillcfa   ( usedcells -- )  T 2 cells H .s Value xt>body
   T cells H xt>body swap - 0 ?DO 0 X c, tchar +LOOP ;  
   
 : (>body)   ( cfa -- pfa )  : (>body)   ( cfa -- pfa )
   xt>body + ;                                   ' (>body) plugin-of t>body    xt>body + ;                                   ' (>body) plugin-of t>body
   
   : fillcfa   ( usedcells -- )
     T cells H xt>body swap - dup .
     assert1( dup 0 >= )
     0 ?DO 0 X c, tchar +LOOP ;
   
 : (doer,)   ( ghost -- )  : (doer,)   ( ghost -- )
   addr, 1 fillcfa ;                             ' (doer,) plugin-of doer,    addr, 1 fillcfa ;                             ' (doer,) plugin-of doer,
   
Line 2252 
Line 2322 
 \ : ; DOES>                                            13dec92py  \ : ; DOES>                                            13dec92py
 \ ]                                                     9may93py/jaw  \ ]                                                     9may93py/jaw
   
 : ]  : compiling-state ( -- )
   \G set states to compililng
     Compiling comp-state !      Compiling comp-state !
     \ if we have a state in target, change it with the compile state      \ if we have a state in target, change it with the compile state
     [G'] state dup undefined? 0= IF >ghost-xt @ execute X on ELSE drop THEN      [G'] state dup undefined? 0=
       IF >ghost-xt @ execute X on ELSE drop THEN ;
   
   : interpreting-state ( -- )
   \G set states to interpreting
      \ if target has a state variable, change it according to our state
      [G'] state dup undefined? 0=
      IF >ghost-xt @ execute X off ELSE drop THEN
      Interpreting comp-state ! ;
   
   : ]
       compiling-state
     BEGIN      BEGIN
         BEGIN save-input bl word          BEGIN save-input bl word
               dup c@ 0= WHILE drop discard refill 0=                dup c@ 0= WHILE drop discard refill 0=
Line 2298 
Line 2380 
 Cond: recurse ( -- ) Last-Header-Ghost @ gexecute ;Cond  Cond: recurse ( -- ) Last-Header-Ghost @ gexecute ;Cond
   
 Cond: ; ( -- )  Cond: ; ( -- )
                depth ?dup IF   1- <> ABORT" CROSS: Stack changed"          depth ?dup
                           ELSE true ABORT" CROSS: Stack empty" THEN          IF   1- <> ABORT" CROSS: Stack changed"
           ELSE true ABORT" CROSS: Stack empty"
           THEN
                colon-end                 colon-end
                fini,                 fini,
                comp[                 comp[
                ;Resolve @                 ;Resolve @
                IF ;Resolve @ ;Resolve cell+ @ resolve THEN          IF      ;Resolve @ ;Resolve cell+ @ resolve
     [G'] state dup undefined? 0= IF >ghost-xt @ execute X off ELSE drop THEN                  ['] colon-resolved ;Resolve @ >comp !
                Interpreting comp-state !          THEN
           interpreting-state
                ;Cond                 ;Cond
 Cond: [  
   \ if we have a state in target, change it with the compile state  Cond: [ ( -- ) interpreting-state ;Cond
     [G'] state dup undefined? 0= IF >ghost-xt @ execute X off ELSE drop THEN  
 \  [G'] state dup undefined? 0= IF ghost>cfa X >body X off ELSE drop THEN  
   Interpreting comp-state ! ;Cond  
   
 >CROSS  >CROSS
   
Line 2328 
Line 2410 
     tlastcfa @ >tempdp dodoes, tempdp> ;      tlastcfa @ >tempdp dodoes, tempdp> ;
   
   
 Defer instant-compile-does>-hook  
 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 IF there resolve THEN ;    Last-Header-Ghost @ >do:ghost @ ?dup
     IF    there resolve
           \ TODO: set special DOES> resolver action here
     THEN ;
   
 >TARGET  >TARGET
 Cond: DOES>  Cond: DOES>
         compile (does>) doeshandler,          compile (does>) doeshandler,
         resolve-does>-part          resolve-does>-part
 \        instant-compile-does>-hook  
         ;Cond          ;Cond
   
 : DOES> switchrom doeshandler, T here H !does  : DOES> switchrom doeshandler, T here H !does
Line 2351 
Line 2434 
   
 \ Builder                                               11may93jaw  \ Builder                                               11may93jaw
   
 : Builder    ( Create-xt do:-xt "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 executet when the created word from builder is executed
 \ for do:-xt an additional entry after the normal ghost-enrys is used  \ for do:-xt an additional entry after the normal ghost-entrys is used
   
   Make-Ghost            ( Create-xt do:-xt ghost )    Make-Ghost            ( Create-xt do-ghost ghost )
   dup >created on    dup >created on
   rot swap              ( do:-xt Create-xt ghost )    rot swap              ( do-ghost Create-xt ghost )
   tuck >exec ! >do:ghost ! ;    tuck >exec !
 \  rot swap >exec dup @ ['] NoExec <>    tuck >do:ghost !
 \  IF 2drop ELSE ! THEN , ;    ['] prim-resolved over >comp !
     drop ;
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built  \ makes the codefield for a word that is built
Line 2381 
Line 2465 
   ;    ;
   
 : takeover-x-semantics ( S constructor-ghost new-ghost -- )  : takeover-x-semantics ( S constructor-ghost new-ghost -- )
 \g stores execution semantic in the built word  \g stores execution semantic and compilation semantic in the built word
 \g if the word already has a semantic (concerns S", IS, .", DOES>)  \g if the word already has a semantic (concerns S", IS, .", DOES>)
 \g then keep it  \g then keep it
    swap >do:ghost @ >exec @ swap >exec2 ! ;     swap >do:ghost @
      \ we use the >exec2 field for the semantic of a crated word,
      \ so predefined semantics e.g. for ....
      \ FIXME: find an example in the normal kernel!!!
      2dup >exec @ swap >exec2 !
      >comp @ swap >comp ! ;
   \ old version of this:
 \  >exec dup @ ['] NoExec =  \  >exec dup @ ['] NoExec =
 \  IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ;  \  IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ;
   
Line 2403 
Line 2493 
   executed-ghost @ (THeader    executed-ghost @ (THeader
   dup >created on    dup >created on
   2dup takeover-x-semantics    2dup takeover-x-semantics
   there 0 T a, H 80 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
Line 2423 
Line 2513 
   
 : gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
   executed-ghost @    executed-ghost @
   \ FIXME: cleanup
 \  compiling? ABORT" CROSS: Executing gdoes> while compiling"  \  compiling? ABORT" CROSS: Executing gdoes> while compiling"
 \ ?! compiling? IF  gexecute true EXIT  THEN  \ ?! compiling? IF  gexecute true EXIT  THEN
   >link @ X >body ( false ) ;    g>body ( false ) ;
   
 \ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw  \ changed to ?EXIT                                      10may93jaw
   
 : DO:     ( -- addr [xt] [colon-sys] )  : DO:     ( -- ghost [xt] [colon-sys] )
   here ghostheader    here ghostheader
   :noname postpone gdoes> ( postpone ?EXIT ) ;    :noname postpone gdoes> ( postpone ?EXIT ) ;
   
 : by:     ( -- addr [xt] [colon-sys] ) \ name  : by:     ( -- ghost [xt] [colon-sys] ) \ name
   Ghost    Ghost
   :noname postpone gdoes> ( postpone ?EXIT ) ;    :noname postpone gdoes> ( postpone ?EXIT ) ;
   
 : ;DO ( addr [xt] [colon-sys] -- addr )  : ;DO ( ghost [xt] [colon-sys] -- addr )
   postpone ;    ( S addr xt )    postpone ;    ( S addr xt )
   over >exec ! ; immediate    over >exec ! ; immediate
   
Line 2569 
Line 2660 
 : cell% ( n -- size align )  : cell% ( n -- size align )
     T 1 cells H dup ;      T 1 cells H dup ;
   
   \ Input-Methods                                            01py
   
 Build: ( m v -- m' v )  dup T , cell+ H ;  Build: ( m v -- m' v )  dup T , cell+ H ;
 DO:  abort" Not in cross mode" ;DO  DO:  abort" Not in cross mode" ;DO
Line 3314 
Line 3405 
 : hwords        words ;  : hwords        words ;
 \ : words       also ghosts  \ : words       also ghosts
 \                words previous ;  \                words previous ;
 \ : .s            .s ;  : .s            .s ;
 : bye           bye ;  : bye           bye ;
   
 \ dummy  \ dummy

Generate output suitable for use with a patch program
Legend:
Removed from v.1.104  
changed lines
  Added in v.1.105
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help