[BACK]Return to cross.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

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

version 1.107, 2001/09/05 11:01:27 version 1.108, 2001/09/05 11:45:38
Line 1822  Defer resolve-warning Line 1822  Defer resolve-warning
   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  Cond: ALiteral ( n -- )   alit, ;Cond Line 2288  Cond: ALiteral ( n -- )   alit, ;Cond
 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 2456  Cond: DOES> Line 2456  Cond: DOES>
   depth T ] H ;    depth T ] H ;
   
 >CROSS  >CROSS
 \ Creation                                             01nov92py  \ Creation                                              01nov92py
   
 \ 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  Cond: DOES> Line 2538  Cond: DOES>
   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  Cond: DOES> Line 2551  Cond: DOES>
 \ 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  Cond: DOES> Line 2574  Cond: DOES>
   :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  Variable tudp 0 tudp ! Line 2644  Variable tudp 0 tudp !
   
 >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  Builder interpret/compile: Line 2686  Builder interpret/compile:
  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  Builder Field Line 2704  Builder Field
   
 \ 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
   
Removed from v.1.107  
changed lines
  Added in v.1.108

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