[gforth] / gforth / cross.fs  

gforth: gforth/cross.fs

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

version 1.91, Mon Jan 29 11:39:43 2001 UTC version 1.94, Sun Mar 11 22:50:49 2001 UTC
Line 656 
Line 656 
 4713 Constant <imm>             4714 Constant <do:>  4713 Constant <imm>             4714 Constant <do:>
 4715 Constant <skip>  4715 Constant <skip>
   
 \ iForth makes only immediate directly after create  \  Compiler States
 \ make atonce trick! ?  
   
 Variable atonce atonce off  Variable comp-state
   0 Constant interpreting
   1 Constant compiling
   2 Constant resolving
   3 Constant assembling
   
 : NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;  Defer lit, ( n -- )
   Defer alit, ( n -- )
   
   Defer branch, ( target-addr -- )        \ compiles a branch
   Defer ?branch, ( target-addr -- )       \ compiles a ?branch
   Defer branchmark, ( -- branch-addr )    \ reserves room for a branch
   Defer ?branchmark, ( -- branch-addr )   \ reserves room for a ?branch
   Defer ?domark, ( -- branch-addr )       \ reserves room for a ?do branch
   Defer branchto, ( -- )                  \ actual program position is target of a branch (do e.g. alignment)
   Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
   Defer branchfrom, ( -- )                \ ?!
   Defer branchtomark, ( -- target-addr )  \ marks a branch destination
   
   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 colon-resolve ( tcfa addr -- )
   
   Defer addr-resolve ( target-addr addr -- )
   Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )
   
   Defer do,       ( -- do-token )
   Defer ?do,      ( -- ?do-token )
   Defer for,      ( -- for-token )
   Defer loop,     ( do-token / ?do-token -- )
   Defer +loop,    ( do-token / ?do-token -- )
   Defer next,     ( for-token )
   
   [IFUNDEF] ca>native
   defer ca>native
   [THEN]
   
 : GhostHeader <fwd> , 0 , ['] NoExec , ;  \ ghost structure
   
 : >magic ;              \ type of ghost  : >magic ;              \ type of ghost
 : >link cell+ ;         \ pointer where ghost is in target, or if unresolved  : >link cell+ ;         \ pointer where ghost is in target, or if unresolved
                         \ points to the where we have to resolve (linked-list)                          \ points to the where we have to resolve (linked-list)
 : >exec cell+ cell+ ;   \ execution symantics (while target compiling) of ghost  : >exec cell+ cell+ ;   \ execution symantics (while target compiling) of ghost
 : >end 3 cells + ;      \ room for additional tags  : >comp 3 cells + ;     \ compilation semantics
   : >end 4 cells + ;      \ room for additional tags
                         \ for builder (create, variable...) words the                          \ for builder (create, variable...) words the
                         \ execution symantics of words built are placed here                          \ execution symantics of words built are placed here
   
   \ resolve structure
   
   : >next ;               \ link to next field
   : >tag cell+ ;          \ indecates type of reference: 0: call, 1: address, 2: doer
   : >taddr cell+ cell+ ;
   : >ghost 3 cells + ;
   : >file 4 cells + ;
   : >line 5 cells + ;
   
   \ refer variables
   
 Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes>  Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes>
 Variable last-ghost     \ last ghost that is created  Variable last-ghost     \ last ghost that is created
 Variable last-header-ghost \ last ghost definitions with header  Variable last-header-ghost \ last ghost definitions with header
   
   : (refered) ( ghost addr tag -- )
   \G creates a reference to ghost at address taddr
       rot >r here r@ >link @ , r> >link !
       ( taddr tag ) ,
       ( taddr ) ,
       last-header-ghost @ ,
       loadfile ,
       sourceline# ,
     ;
   
   \ iForth makes only immediate directly after create
   \ make atonce trick! ?
   
   Variable atonce atonce off
   
   : NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;
   
   : is-forward   ( ghost -- )
     colonmark, 0 (refered) ; \ compile space for call
   
   : GhostHeader <fwd> , 0 , ['] NoExec , ['] is-forward , ;
   
 : Make-Ghost ( "name" -- ghost )  : Make-Ghost ( "name" -- ghost )
   >in @ GhostName swap >in !    >in @ GhostName swap >in !
   <T Create atonce @ IF immediate atonce off THEN    <T Create atonce @ IF immediate atonce off THEN
Line 740 
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                                    drop  ghost :dovar    ghost :dodefer  ghost :dofield  2drop drop
 ghost over      ghost =         ghost drop      2drop drop  ghost over      ghost =         ghost drop      2drop drop
 ghost - drop  ghost call      ghost useraddr  ghost execute   2drop drop
   ghost +         ghost -         ghost @         2drop drop
 ghost 2drop drop  ghost 2drop drop
 ghost 2dup drop  ghost 2dup drop
   
Line 802 
Line 871 
 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 new-input
 [THEN]  [THEN]
   
Line 1267 
Line 1337 
   
 \ \ --------------------        Compiler Plug Ins               01aug97jaw  \ \ --------------------        Compiler Plug Ins               01aug97jaw
   
 \  Compiler States  
   
 Variable comp-state  
 0 Constant interpreting  
 1 Constant compiling  
 2 Constant resolving  
 3 Constant assembling  
   
 Defer lit, ( n -- )  
 Defer alit, ( n -- )  
   
 Defer branch, ( target-addr -- )        \ compiles a branch  
 Defer ?branch, ( target-addr -- )       \ compiles a ?branch  
 Defer branchmark, ( -- branch-addr )    \ reserves room for a branch  
 Defer ?branchmark, ( -- branch-addr )   \ reserves room for a ?branch  
 Defer ?domark, ( -- branch-addr )       \ reserves room for a ?do branch  
 Defer branchto, ( -- )                  \ actual program position is target of a branch (do e.g. alignment)  
 Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark  
 Defer branchfrom, ( -- )                \ ?!  
 Defer branchtomark, ( -- target-addr )  \ marks a branch destination  
   
 Defer colon, ( tcfa -- )                \ compiles call to tcfa at current position  
 Defer colonmark, ( -- addr )            \ marks a colon call  
 Defer colon-resolve ( tcfa addr -- )  
   
 Defer addr-resolve ( target-addr addr -- )  
 Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )  
   
 Defer do,       ( -- do-token )  
 Defer ?do,      ( -- ?do-token )  
 Defer for,      ( -- for-token )  
 Defer loop,     ( do-token / ?do-token -- )  
 Defer +loop,    ( do-token / ?do-token -- )  
 Defer next,     ( for-token )  
   
 [IFUNDEF] ca>native  
 defer ca>native  
 [THEN]  
   
 >TARGET  >TARGET
 DEFER >body             \ we need the system >body  DEFER >body             \ we need the system >body
                         \ and the target >body                          \ and the target >body
Line 1321 
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 1335 
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
   
 \ resolve structure  
   
 : >next ;               \ link to next field  
 : >tag cell+ ;          \ indecates type of reference: 0: call, 1: address, 2: doer  
 : >taddr cell+ cell+ ;  
 : >ghost 3 cells + ;  
 : >file 4 cells + ;  
 : >line 5 cells + ;  
   
 : (refered) ( ghost addr tag -- )  
 \G creates a reference to ghost at address taddr  
     rot >r here r@ >link @ , r> >link !  
     ( taddr tag ) ,  
     ( taddr ) ,  
     last-header-ghost @ ,  
     loadfile ,  
     sourceline# ,  
   ;  
   
 : refered ( ghost tag -- )  : refered ( ghost tag -- )
 \G creates a resolve structure  \G creates a resolve structure
     T here aligned H swap (refered)      T here aligned H swap (refered)
Line 1429 
Line 1441 
   ELSE  true abort" CROSS: Ghostnames inconsistent "    ELSE  true abort" CROSS: Ghostnames inconsistent "
   THEN ;    THEN ;
   
   : colon-resolved   ( ghost -- )
       >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
     \ is ghost resolved?, second resolve means another definition with the      \ is ghost resolved?, second resolve means another definition with the
Line 1438 
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
           ['] 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 1449 
Line 1468 
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
 : is-forward   ( ghost -- )  
   colonmark, 0 (refered) ; \ compile space for call  
   
 : is-resolved   ( ghost -- )  
   >link @ colon, ; \ compile-call  
   
 : gexecute   ( ghost -- )  : gexecute   ( ghost -- )
   dup @ <fwd> = IF  is-forward  ELSE  is-resolved  THEN ;      dup >comp @ execute ;
   
 : addr,  ( ghost -- )  : addr,  ( ghost -- )
   dup @ <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 1764 
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 1797 
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 1867 
Line 1882 
 \ some special literals                                 27jan97jaw  \ some special literals                                 27jan97jaw
   
 \ !! Known Bug: Special Literals and plug-ins work only correct  \ !! Known Bug: Special Literals and plug-ins work only correct
 \ on 16 and 32 Bit Targets and 32 Bit Hosts!  \ on targets with char = 8 bit
   
 Cond: MAXU  Cond: MAXU
   restrict?    restrict?
   tcell 1 cells u>    compile lit tcell 0 ?DO FF T c, H LOOP
   IF    compile lit tcell 0 ?DO FF T c, H LOOP  
   ELSE  ffffffff lit, THEN  
   ;Cond    ;Cond
   
 Cond: MINI  Cond: MINI
   restrict?    restrict?
   tcell 1 cells u>    compile lit bigendian
   IF    compile lit bigendian  
         IF      80 T c, H tcell 1 ?DO 0 T c, H LOOP          IF      80 T c, H tcell 1 ?DO 0 T c, H LOOP
         ELSE    tcell 1 ?DO 0 T c, H LOOP 80 T c, H          ELSE    tcell 1 ?DO 0 T c, H LOOP 80 T c, H
         THEN          THEN
   ELSE  tcell 2 = IF 8000 ELSE 80000000 THEN lit, THEN  
   ;Cond    ;Cond
   
 Cond: MAXI  Cond: MAXI
  restrict?   restrict?
  tcell 1 cells u>   compile lit bigendian
  IF     compile lit bigendian  
         IF      7F T c, H tcell 1 ?DO FF T c, H LOOP          IF      7F T c, H tcell 1 ?DO FF T c, H LOOP
         ELSE    tcell 1 ?DO FF T c, H LOOP 7F T c, H          ELSE    tcell 1 ?DO FF T c, H LOOP 7F T c, H
         THEN          THEN
  ELSE   tcell 2 = IF 7fff ELSE 7fffffff THEN lit, THEN  
  ;Cond   ;Cond
   
 >CROSS  >CROSS
Line 1966 
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 1997 
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 ! , ;
 \  rot swap >exec dup @ ['] NoExec <>  
 \  IF 2drop ELSE ! THEN , ;  
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built  \ makes the codefield for a word that is built
Line 2033 
Line 2041 
 \ stores execution semantic in the built word  \ stores execution semantic in the built word
 \ if the word already has a semantic (concerns S", IS, .", DOES>)  \ if the word already has a semantic (concerns S", IS, .", DOES>)
 \ then keep it  \ then keep it
   >end @ >exec @ r> >exec dup @ ['] NoExec =    >end @
   IF ! ELSE 2drop THEN ;    dup >exec @ r@ >exec dup @ ['] NoExec =  IF ! ELSE 2drop THEN
     >comp @ r> >comp ! ;
   
 : RTCreate ( <name> -- )  : RTCreate ( <name> -- )
 \ creates a new word with code-field in ram  \ creates a new word with code-field in ram
Line 2066 
Line 2075 
   postpone TCreate    postpone TCreate
   [ [THEN] ] ;    [ [THEN] ] ;
   
   : g>body ( ghost -- body )
       >link @ T >body H ;
 : gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
   executed-ghost @    executed-ghost @
   state @ IF  gexecute true EXIT  THEN    state @ IF  gexecute true EXIT  THEN
   >link @ T >body H 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] -- ghost )
   postpone ;    ( S addr xt )    postpone ;    ( S addr xt )
   over >exec ! ; immediate    over >exec ! ; immediate
   
 : by      ( -- addr ) \ Name  : compile: ( ghost -- ghost [xt] [colon-sys] )
       :noname  postpone g>body ;
   : ;compile ( ghost [xt] [colon-sys] -- ghost )
       postpone ;  over >comp ! ; immediate
   
   : by      ( -- ghost ) \ Name
   ghost >end @ ;    ghost >end @ ;
   
 >TARGET  >TARGET
Line 2094 
Line 2110 
   
 Build:  ( n -- ) ;  Build:  ( n -- ) ;
 by: :docon ( ghost -- n ) T @ H ;DO  by: :docon ( ghost -- n ) T @ H ;DO
   compile: alit, compile @ ;compile
 Builder (Constant)  Builder (Constant)
   
 Build:  ( n -- ) T , H ;  Build:  ( n -- ) T , H ;
Line 2110 
Line 2127 
   
 BuildSmart: ;  BuildSmart: ;
 by: :dovar ( ghost -- addr ) ;DO  by: :dovar ( ghost -- addr ) ;DO
   compile: alit, ;compile
 Builder Create  Builder Create
   
 T has? rom H [IF]  T has? rom H [IF]
Line 2161 
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 T @ , H ;compile
 Builder User  Builder User
   
 Build: 0 u, X , 0 u, drop ;  Build: 0 u, X , 0 u, drop ;
Line 2181 
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
 Builder Defer  Builder Defer
   
 Build: ( inter comp -- ) swap T immediate A, A, H ;  Build: ( inter comp -- ) swap T immediate A, A, H ;
Line 2197 
Line 2217 
   
 Build: ;  Build: ;
 by: :dofield T @ H + ;DO  by: :dofield T @ H + ;DO
   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 2367 
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.91  
changed lines
  Added in v.1.94
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help