[gforth] / gforth / cross.fs  

gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.109 and 1.110

version 1.109, Wed Sep 5 13:11:36 2001 UTC version 1.110, Wed Sep 5 14:25:48 2001 UTC
Line 986 
Line 986 
   
 Variable reuse-ghosts reuse-ghosts off  Variable reuse-ghosts reuse-ghosts off
   
 1 [IF] \ FIXME: define when vocs are ready  
 : HeaderGhost ( "name" -- ghost )  : HeaderGhost ( "name" -- ghost )
   >in @    >in @
   bl word count    bl word count
Line 1003 
Line 1002 
   \ defined words, this is a workaround    \ defined words, this is a workaround
   \ for the redefined \ until vocs work    \ for the redefined \ until vocs work
   Make-Ghost ;    Make-Ghost ;
 [THEN]  
   
   
 : .ghost ( ghost -- ) >ghostname type ;  : .ghost ( ghost -- ) >ghostname type ;
   
Line 1640 
Line 1637 
 >TARGET  >TARGET
   
 : count dup X c@ swap X char+ swap ;  : count dup X c@ swap X char+ swap ;
 \ FIXME -1 on 64 bit machines?!?!  
 : on            T -1 swap ! H ;  : on            -1 -1 rot TD!  ;
 : off           T 0 swap ! H ;  : off           T 0 swap ! H ;
   
 : tcmove ( source dest len -- )  : tcmove ( source dest len -- )
Line 1774 
Line 1771 
 : prim-resolved  ( ghost -- )  : prim-resolved  ( ghost -- )
     >link @ prim, ;      >link @ prim, ;
   
 \ FIXME: not activated  \ FIXME: not used currently
 : does-resolved ( ghost -- )  : does-resolved ( ghost -- )
     dup g>body alit, >do:ghost @ g>body colon, ;      dup g>body alit, >do:ghost @ g>body colon, ;
   
Line 1814 
Line 1811 
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
 \ FIXME cleanup  
 \ : is-resolved   ( ghost -- )  
 \  >link @ colon, ; \ compile-call  
   
 : (gexecute)   ( ghost -- )  : (gexecute)   ( ghost -- )
   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 -- )
   dup forward? 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 ;  
   
 \ .unresolved                                          11may93jaw  \ .unresolved                                          11may93jaw
   
 variable ResolveFlag  variable ResolveFlag
Line 2288 
Line 2279 
 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 2376 
Line 2367 
 \ by the way: defining a second interpreter (a compiler-)loop  \ by the way: defining a second interpreter (a compiler-)loop
 \             is not allowed if a system should be ans conform  \             is not allowed if a system should be ans conform
   
   : (:) ( ghost -- )
   \ common factor of : and :noname. Prepare ;Resolve and start definition
      ;Resolve ! there ;Resolve cell+ !
      docol, ]comp  colon-start depth T ] H ;
   
 : : ( -- colon-sys ) \ Name  : : ( -- colon-sys ) \ Name
   defempty?    defempty?
   constflag off \ don't let this flag work over colon defs    constflag off \ don't let this flag work over colon defs
                 \ just to go sure nothing unwanted happens                  \ just to go sure nothing unwanted happens
   >in @ skip? IF  drop skip-defs  EXIT  THEN  >in !    >in @ skip? IF  drop skip-defs  EXIT  THEN  >in !
   (THeader ;Resolve ! there ;Resolve cell+ !    (THeader (:) ;
    docol, ]comp  colon-start depth T ] H ;  
   
 : :noname ( -- colon-sys )  : :noname ( -- colon-sys )
   X cfalign    X cfalign there
   \ FIXME: cleanup!!!!!!!!    \ define a nameless ghost
   \ idtentical to : with dummy ghost?!    here ghostheader dup last-header-ghost ! dup to lastghost
   here ghostheader dup ;Resolve ! dup last-header-ghost ! to lastghost    (:) ;
   there ;Resolve cell+ !  
   there docol, ]comp  
   colon-start depth T ] H ;  
   
 Cond: EXIT ( -- )   compile ;S  ;Cond  Cond: EXIT ( -- )   compile ;S  ;Cond
   
Line 2492 
Line 2484 
   
 : takeover-x-semantics ( S constructor-ghost new-ghost -- )  : takeover-x-semantics ( S constructor-ghost new-ghost -- )
 \g stores execution semantic and compilation 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 then keep it  
    swap >do:ghost @     swap >do:ghost @
    \ we use the >exec2 field for the semantic of a crated word,     \ we use the >exec2 field for the semantic of a created word,
    \ so predefined semantics e.g. for ....     \ using exec or exec2 makes no difference for normal cross-compilation
    \ FIXME: find an example in the normal kernel!!!     \ but is usefull for instant where the exec field is already
      \ defined (e.g. Vocabularies)
    2dup >exec @ swap >exec2 !     2dup >exec @ swap >exec2 !
 \   cr ." XXX" over .ghost  
 \   dup >comp @ xt-see  
    >comp @ swap >comp ! ;     >comp @ swap >comp ! ;
 \ old version of this:  
 \  >exec dup @ ['] NoExec =  
 \  IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ;  
   
 : TCreate ( <name> -- )  : TCreate ( <name> -- )
   create-forward-warn    create-forward-warn
Line 2543 
Line 2529 
   postpone ; built >exec ! ; immediate    postpone ; built >exec ! ; immediate
   
 : gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
   executed-ghost @    executed-ghost @ g>body ;
 \ FIXME: cleanup  
 \  compiling? ABORT" CROSS: Executing gdoes> while compiling"  
 \ ?! compiling? IF  gexecute true EXIT  THEN  
   g>body ( false ) ;  
   
 \ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw  
   
 : do:ghost! ( ghost -- ) built >do:ghost ! ;  : do:ghost! ( ghost -- ) built >do:ghost ! ;
 : doexec! ( xt -- ) built >do:ghost @ >exec ! ;  : doexec! ( xt -- ) built >do:ghost @ >exec ! ;
   
 : DO:     ( -- [xt] [colon-sys] )  : DO:     ( -- [xt] [colon-sys] )
   here ghostheader do:ghost!    here ghostheader do:ghost!
   :noname postpone gdoes> ( postpone ?EXIT ) ;    :noname postpone gdoes> ;
   
 : by:     ( -- [xt] [colon-sys] ) \ name  : by:     ( -- [xt] [colon-sys] ) \ name
   Ghost do:ghost!    Ghost do:ghost!
   :noname postpone gdoes> ( postpone ?EXIT ) ;    :noname postpone gdoes> ;
   
 : ;DO ( [xt] [colon-sys] -- )  : ;DO ( [xt] [colon-sys] -- )
   postpone ; doexec! ; immediate    postpone ; doexec! ; immediate
Line 3050 
Line 3031 
   swap >image swap r@ write-file throw    swap >image swap r@ write-file throw
   r> close-file throw ;    r> close-file throw ;
   
 1 [IF]  \ save-asm-region                                       29aug01jaw
   
 Variable name-ptr  Variable name-ptr
 Create name-buf 200 chars allot  Create name-buf 200 chars allot
Line 3257 
Line 3238 
 : save-asm-region ( region adr len -- )  : save-asm-region ( region adr len -- )
   create-outfile (save-asm-region) close-outfile ;    create-outfile (save-asm-region) close-outfile ;
   
 [THEN]  
   
 \ \ minimal definitions  \ \ minimal definitions
   
 >MINIMAL also minimal  >MINIMAL also minimal

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help