[gforth] / gforth / cross.fs  

gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.93 and 1.94

version 1.93, Sun Mar 11 21:47:27 2001 UTC version 1.94, Sun Mar 11 22:50:49 2001 UTC
Line 678 
Line 678 
 Defer branchtomark, ( -- target-addr )  \ marks a branch destination  Defer branchtomark, ( -- target-addr )  \ marks a branch destination
   
 Defer colon, ( tcfa -- )                \ compiles call to tcfa at current position  Defer colon, ( tcfa -- )                \ compiles call to tcfa at current position
   Defer prim, ( tcfa -- )                 \ compiles a primitive invocation
                                           \ at current position
 Defer colonmark, ( -- addr )            \ marks a colon call  Defer colonmark, ( -- addr )            \ marks a colon call
 Defer colon-resolve ( tcfa addr -- )  Defer colon-resolve ( tcfa addr -- )
   
Line 806 
Line 808 
 ghost unloop    ghost ;S                        2drop  ghost unloop    ghost ;S                        2drop
 ghost lit       ghost (compile) ghost !         2drop drop  ghost lit       ghost (compile) ghost !         2drop drop
 ghost (does>)   ghost noop                      2drop  ghost (does>)   ghost noop                      2drop
 ghost (.")      ghost (S")      ghost (ABORT")  2drop drop  ghost (.")      ghost (S")      ghost (ABORT")  2drop drop ( " )
 ghost '                                         drop  ghost '                                         drop
 ghost :docol    ghost :doesjump ghost :dodoes   2drop drop  ghost :docol    ghost :doesjump ghost :dodoes   2drop drop
 ghost :dovar    ghost :dodefer  ghost :dofield  2drop drop  ghost :dovar    ghost :dodefer  ghost :dofield  2drop drop
Line 1350 
Line 1352 
 DEFER ]comp     \ starts compilation  DEFER ]comp     \ starts compilation
 DEFER comp[     \ ends compilation  DEFER comp[     \ ends compilation
   
 : (cc) T a, H ;                                 ' (cc) IS colon,  : (prim) T a, H ;                               ' (prim) IS prim,
   
 : (cr) >tempdp ]comp colon, comp[ tempdp> ;     ' (cr) IS colon-resolve  : (cr) >tempdp ]comp prim, comp[ tempdp> ;      ' (cr) IS colon-resolve
 : (ar) T ! H ;                                  ' (ar) IS addr-resolve  : (ar) T ! H ;                                  ' (ar) IS addr-resolve
 : (dr)  ( ghost res-pnt target-addr addr )  : (dr)  ( ghost res-pnt target-addr addr )
         >tempdp drop over          >tempdp drop over
Line 1364 
Line 1366 
   
 : (cm) ( -- addr )  : (cm) ( -- addr )
     T here align H      T here align H
     -1 colon, ;                                 ' (cm) IS colonmark,      -1 prim, ;                                  ' (cm) IS colonmark,
   
 >TARGET  >TARGET
 : compile, colon, ;  : compile, prim, ;
 >CROSS  >CROSS
   
 : refered ( ghost tag -- )  : refered ( ghost tag -- )
Line 1439 
Line 1441 
   ELSE  true abort" CROSS: Ghostnames inconsistent "    ELSE  true abort" CROSS: Ghostnames inconsistent "
   THEN ;    THEN ;
   
 : is-resolved   ( ghost -- )  : colon-resolved   ( ghost -- )
   >link @ colon, ; \ compile-call    >link @ colon, ; \ compile-call
   : prim-resolved  ( ghost -- )
       >link @ prim, ;
   
 : resolve  ( ghost tcfa -- )  : resolve  ( ghost tcfa -- )
 \G resolve referencies to ghost with tcfa  \G resolve referencies to ghost with tcfa
Line 1451 
Line 1455 
     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  ['] is-resolved r@ >comp !  THEN      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 1772 
Line 1777 
   ELSE  postpone literal postpone gexecute  THEN ;    ELSE  postpone literal postpone gexecute  THEN ;
                                         immediate                                          immediate
   
   : (cc) compile call T a, H ;            ' (cc) IS colon,
   
 : [G']  : [G']
 \G ticks a ghost and returns its address  \G ticks a ghost and returns its address
   bl word gfind 0= ABORT" CROSS: Ghost don't exists"    bl word gfind 0= ABORT" CROSS: Ghost don't exists"
Line 1805 
Line 1812 
   
 : (>body)   ( cfa -- pfa ) xt>body + ;          ' (>body) T IS >body H  : (>body)   ( cfa -- pfa ) xt>body + ;          ' (>body) T IS >body H
   
 : (doer,)   ( ghost -- ) ]comp gexecute comp[ 1 fillcfa ;   ' (doer,) IS doer,  : (doer,)   ( ghost -- ) ]comp addr, comp[ 1 fillcfa ;   ' (doer,) IS doer,
   
 : (docol,)  ( -- ) [G'] :docol doer, ;          ' (docol,) IS docol,  : (docol,)  ( -- ) [G'] :docol doer, ;          ' (docol,) IS docol,
   
Line 1968 
Line 1975 
                comp[                 comp[
                state off                 state off
                ;Resolve @                 ;Resolve @
                IF ;Resolve @ ;Resolve cell+ @ resolve THEN                 IF ;Resolve @ ;Resolve cell+ @ resolve
                     ['] prim-resolved ;Resolve @ >comp ! THEN
                 Interpreting comp-state !                  Interpreting comp-state !
                ;Cond                 ;Cond
 Cond: [  restrict? state off Interpreting comp-state ! ;Cond  Cond: [  restrict? state off Interpreting comp-state ! ;Cond
Line 1999 
Line 2007 
   
 \ 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-enrys is used
   
   Make-Ghost            ( Create-xt do:-xt ghost )    Make-Ghost            ( Create-xt do-ghost ghost )
   rot swap              ( do:-xt Create-xt ghost )    rot swap              ( do-ghost Create-xt ghost )
   >exec ! , ;    >exec ! , ;
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
Line 2092 
Line 2100 
 : compile: ( ghost -- ghost [xt] [colon-sys] )  : compile: ( ghost -- ghost [xt] [colon-sys] )
     :noname  postpone g>body ;      :noname  postpone g>body ;
 : ;compile ( ghost [xt] [colon-sys] -- ghost )  : ;compile ( ghost [xt] [colon-sys] -- ghost )
     postpone ;  over >comp ! ;      postpone ;  over >comp ! ; immediate
   
 : by      ( -- ghost ) \ Name  : by      ( -- ghost ) \ Name
   ghost >end @ ;    ghost >end @ ;
Line 2102 
Line 2110 
   
 Build:  ( n -- ) ;  Build:  ( n -- ) ;
 by: :docon ( ghost -- n ) T @ H ;DO  by: :docon ( ghost -- n ) T @ H ;DO
 \ compile: alit, compile @ ;compile  compile: alit, compile @ ;compile
 Builder (Constant)  Builder (Constant)
   
 Build:  ( n -- ) T , H ;  Build:  ( n -- ) T , H ;
Line 2119 
Line 2127 
   
 BuildSmart: ;  BuildSmart: ;
 by: :dovar ( ghost -- addr ) ;DO  by: :dovar ( ghost -- addr ) ;DO
 \ compile: alit, ;compile  compile: alit, ;compile
 Builder Create  Builder Create
   
 T has? rom H [IF]  T has? rom H [IF]
Line 2171 
Line 2179 
   
 Build: 0 u, X , ;  Build: 0 u, X , ;
 by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO  by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO
 \ compile: compile useraddr @ , ;compile  compile: compile useraddr T @ , H ;compile
 Builder User  Builder User
   
 Build: 0 u, X , 0 u, drop ;  Build: 0 u, X , 0 u, drop ;
Line 2192 
Line 2200 
   
 BuildSmart:  ( -- ) [T'] noop T A, H ;  BuildSmart:  ( -- ) [T'] noop T A, H ;
 by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 \ compile: alit, compile @ compile execute ;compile  compile: alit, compile @ compile execute ;compile
 Builder Defer  Builder Defer
   
 Build: ( inter comp -- ) swap T immediate A, A, H ;  Build: ( inter comp -- ) swap T immediate A, A, H ;
Line 2209 
Line 2217 
   
 Build: ;  Build: ;
 by: :dofield T @ H + ;DO  by: :dofield T @ H + ;DO
 \ compile: T @ H lit, compile + ;compile  compile: T @ H lit, compile + ;compile
 Builder (Field)  Builder (Field)
   
 Build: ( align1 offset1 align size "name" --  align2 offset2 )  Build: ( align1 offset1 align size "name" --  align2 offset2 )
Line 2380 
Line 2388 
   
 : ,"            [char] " parse T string, align H ;  : ,"            [char] " parse T string, align H ;
   
 Cond: ."        restrict? compile (.")     T ," H ;Cond  Cond: ."        restrict? compile (.")     T ," H ;Cond ( " )
 Cond: S"        restrict? compile (S")     T ," H ;Cond  Cond: S"        restrict? compile (S")     T ," H ;Cond ( " )
 Cond: ABORT"    restrict? compile (ABORT") T ," H ;Cond  Cond: ABORT"    restrict? compile (ABORT") T ," H ;Cond ( " )
   
 Cond: IS        T ' >body H compile ALiteral compile ! ;Cond  Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
 : IS            T >address ' >body ! H ;  : IS            T >address ' >body ! H ;

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help