[gforth] / gforth / cross.fs  

gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.107 and 1.108

version 1.107, Wed Sep 5 11:01:27 2001 UTC version 1.108, Wed Sep 5 11:45:38 2001 UTC
Line 1822 
Line 1822 
   dup >comp @ EXECUTE ;    dup >comp @ EXECUTE ;
   
 : 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 -- )
Line 2288 
Line 2288 
 Cond: [Char]   ( "<char>" -- )  Char  lit, ;Cond  Cond: [Char]   ( "<char>" -- )  Char  lit, ;Cond
   
 tchar 1 = [IF]  tchar 1 = [IF]
 Cond: chars ;Cond  \ Cond: chars ;Cond
 [THEN]  [THEN]
   
 \ some special literals                                 27jan97jaw  \ some special literals                                 27jan97jaw
Line 2460 
Line 2460 
   
 \ Builder                                               11may93jaw  \ Builder                                               11may93jaw
   
   0 Value built
   
 : Builder    ( Create-xt do-ghost "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 executed when the created word from builder is executed  \ do:-xt is executed when the created word from builder is executed
 \ for do:-xt an additional entry after the normal ghost-entrys is used  \ for do:-xt an additional entry after the normal ghost-entrys is used
   
   Make-Ghost            ( Create-xt do-ghost ghost )    ghost                 ( Create-xt do-ghost ghost )
   dup >created on    to built
   rot swap              ( do-ghost Create-xt ghost )    built >created @ 0= IF
   tuck >exec !      built >created on
   tuck >do:ghost !      ['] prim-resolved built >comp !
   ['] prim-resolved over >comp !    THEN ;
   drop ;  
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built  \ makes the codefield for a word that is built
Line 2537 
Line 2538 
   postpone TCreate    postpone TCreate
   [ [THEN] ] ;    [ [THEN] ] ;
   
   : ;Build
     postpone ; built >exec ! ; immediate
   
 : gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
   executed-ghost @    executed-ghost @
 \ FIXME: cleanup  \ FIXME: cleanup
Line 2547 
Line 2551 
 \ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw  \ changed to ?EXIT                                      10may93jaw
   
 : DO:     ( -- do-ghost [xt] [colon-sys] )  : do:ghost! ( ghost -- ) built >do:ghost ! ;
   here ghostheader  : doexec! ( xt -- ) built >do:ghost @ >exec ! ;
   
   : DO:     ( -- [xt] [colon-sys] )
     here ghostheader do:ghost!
   :noname postpone gdoes> ( postpone ?EXIT ) ;    :noname postpone gdoes> ( postpone ?EXIT ) ;
   
 : by:     ( -- do-ghost [xt] [colon-sys] ) \ name  : by:     ( -- [xt] [colon-sys] ) \ name
   Ghost    Ghost do:ghost!
   :noname postpone gdoes> ( postpone ?EXIT ) ;    :noname postpone gdoes> ( postpone ?EXIT ) ;
   
 : ;DO ( do-ghost [xt] [colon-sys] -- do-ghost )  : ;DO ( [xt] [colon-sys] -- )
   postpone ;    ( S addr xt )    postpone ; doexec! ; immediate
   over >exec ! ; immediate  
   
 : by      ( -- do-ghost ) \ Name  : by      ( -- do-ghost ) \ Name
   Ghost >do:ghost @ ;    Ghost >do:ghost @ do:ghost! ;
   
 : compile: ( do-ghost -- do-ghost [xt] [colon-sys] )  : compile: ( do-ghost -- do-ghost [xt] [colon-sys] )
 \G defines a compile time action for created words  \G defines a compile time action for created words
Line 2568 
Line 2574 
   :noname ;    :noname ;
   
 : ;compile ( do-ghost [xt] [colon-sys] -- do-ghost )  : ;compile ( do-ghost [xt] [colon-sys] -- do-ghost )
   postpone ;  over >comp ! ; immediate    postpone ;  built >do:ghost @ >comp ! ; immediate
   
   
   
 >TARGET  >TARGET
 \ Variables and Constants                              05dec92py  \ Variables and Constants                              05dec92py
   
 Build:  ( n -- ) ;  
 by: :docon ( target-body-addr -- n ) T @ H ;DO  
 Builder (Constant)  Builder (Constant)
   Build:  ( n -- ) ;Build
   by: :docon ( target-body-addr -- n ) T @ H ;DO
   
 Build:  ( n -- ) T , H ;  
 by (Constant)  
 Builder Constant  Builder Constant
   Build:  ( n -- ) T , H ;Build
 Build:  ( n -- ) T A, H ;  
 by (Constant)  by (Constant)
   
 Builder AConstant  Builder AConstant
   Build:  ( n -- ) T A, H ;Build
   by (Constant)
   
 Build:  ( d -- ) T , , H ;  
 DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO  
 Builder 2Constant  Builder 2Constant
   Build:  ( d -- ) T , , H ;Build
   DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
   
 BuildSmart: ;  
 by: :dovar ( target-body-addr -- addr ) ;DO  
 Builder Create  Builder Create
   BuildSmart: ;Build
   by: :dovar ( target-body-addr -- addr ) ;DO
   
   Builder Variable
 T has? rom H [IF]  T has? rom H [IF]
 Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , H ( switchrom ) ;  Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , H ( switchrom ) ;Build
 by (Constant)  by (Constant)
 Builder Variable  
 [ELSE]  [ELSE]
 Build: T 0 , H ;  Build: T 0 , H ;Build
 by Create  by Create
 Builder Variable  
 [THEN]  [THEN]
   
   Builder 2Variable
 T has? rom H [IF]  T has? rom H [IF]
 Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;  Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;Build
 by (Constant)  by (Constant)
 Builder 2Variable  
 [ELSE]  [ELSE]
 Build: T 0 , 0 , H ;  Build: T 0 , 0 , H ;Build
 by Create  by Create
 Builder 2Variable  
 [THEN]  [THEN]
   
   Builder AVariable
 T has? rom H [IF]  T has? rom H [IF]
 Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 A, H ( switchrom ) ;  Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 A, H ( switchrom ) ;Build
 by (Constant)  by (Constant)
 Builder AVariable  
 [ELSE]  [ELSE]
 Build: T 0 A, H ;  Build: T 0 A, H ;Build
 by Create  by Create
 Builder AVariable  
 [THEN]  [THEN]
   
 \ User variables                                       04may94py  \ User variables                                       04may94py
Line 2642 
Line 2644 
   
 >TARGET  >TARGET
   
 Build: 0 u, X , ;  
 by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO  
 Builder User  Builder User
   Build: 0 u, X , ;Build
   by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO
   
 Build: 0 u, X , 0 u, drop ;  
 by User  
 Builder 2User  Builder 2User
   Build: 0 u, X , 0 u, drop ;Build
 Build: 0 au, X , ;  
 by User  by User
   
 Builder AUser  Builder AUser
   Build: 0 au, X , ;Build
   by User
   
   Builder (Value)
   Build:  ( n -- ) ;Build
   by: :docon ( target-body-addr -- n ) T @ H ;DO
   
 BuildSmart: T , H ;  
 by (Constant)  
 Builder Value  Builder Value
   BuildSmart: T , H ;Build
   by (Value)
   
 BuildSmart: T A, H ;  
 by (Constant)  
 Builder AValue  Builder AValue
   BuildSmart: T A, H ;Build
   by (Value)
   
 Defer texecute  Defer texecute
   
 BuildSmart:  ( -- ) [T'] noop T A, H ;  
 by: :dodefer ( ghost -- ) X @ texecute ;DO  
 Builder Defer  Builder Defer
   BuildSmart:  ( -- ) [T'] noop T A, H ;Build
   by: :dodefer ( ghost -- ) X @ texecute ;DO
   
 Build: ( inter comp -- ) swap T immediate A, A, H ;  
 DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  
 Builder interpret/compile:  Builder interpret/compile:
   Build: ( inter comp -- ) swap T immediate A, A, H ;Build
   DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
   
 \ Sturctures                                           23feb95py  \ Sturctures                                           23feb95py
   
Line 2680 
Line 2686 
  1- tuck +  swap invert and ;   1- tuck +  swap invert and ;
 >TARGET  >TARGET
   
 Build: ;  
 by: :dofield T @ H + ;DO  
 Builder (Field)  Builder (Field)
   Build: ;Build
   by: :dofield T @ H + ;DO
   
   Builder Field
 Build: ( align1 offset1 align size "name" --  align2 offset2 )  Build: ( align1 offset1 align size "name" --  align2 offset2 )
     rot dup T , H ( align1 align size offset1 )      rot dup T , H ( align1 align size offset1 )
     + >r nalign r> ;      + >r nalign r> ;Build
 by (Field)  by (Field)
 Builder Field  
   
 : struct  T 1 chars 0 H ;  : struct  T 1 chars 0 H ;
 : end-struct  T 2Constant H ;  : end-struct  T 2Constant H ;
Line 2698 
Line 2704 
   
 \ Input-Methods                                            01py  \ Input-Methods                                            01py
   
 Build: ( m v -- m' v )  dup T , cell+ H ;  
 DO:  abort" Not in cross mode" ;DO  
 Builder input-method  Builder input-method
   Build: ( m v -- m' v )  dup T , cell+ H ;Build
 Build: ( m v size -- m v' )  over T , H + ;  
 DO:  abort" Not in cross mode" ;DO  DO:  abort" Not in cross mode" ;DO
   
 Builder input-var  Builder input-var
   Build: ( m v size -- m v' )  over T , H + ;Build
   DO:  abort" Not in cross mode" ;DO
   
   \ Peephole optimization                                 05sep01jaw
   
   \ this section defines different compilation
   \ actions for created words
   \ this will help the peephole optimizer
   \ I (jaw) took this from bernds lates cross-compiler
   \ changes but seperated it from the original
   \ Builder words. The final plan is to put this
   \ into a seperate file, together with the peephole
   \ optimizer for cross
   
   
   T has? peephole H [IF]
   
   : (cc) compile call T >body a, H ;              ' (cc) IS colon,
   
   Builder (Constant)
   compile: g>body X @ lit, ;compile
   
   Builder (Value)
   compile: g>body alit, compile @ ;compile
   
   \ this changes also Variable, AVariable and 2Variable
   Builder Create
   \ compile: g>body alit, ;compile
   
   Builder User
   compile: g>body compile useraddr T @ , H ;compile
   
   Builder Defer
   compile: g>body alit, compile @ compile execute ;compile
   
   Builder (Field)
   compile: g>body T @ H lit, compile + ;compile
   
   [THEN]
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py
   

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help