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

version 1.109, 2001/09/05 13:11:36 version 1.110, 2001/09/05 14:25:48
Line 986  Exists-Warnings on Line 986  Exists-Warnings on
   
 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  Variable reuse-ghosts reuse-ghosts off Line 1002  Variable reuse-ghosts reuse-ghosts off
   \ 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  T has? relocate H Line 1637  T has? relocate H
 >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  Defer resolve-warning Line 1771  Defer resolve-warning
 : 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  Defer resolve-warning Line 1811  Defer resolve-warning
   
 \ 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  Cond: ALiteral ( n -- )   alit, ;Cond Line 2279  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 2376  Cond: MAXI Line 2367  Cond: MAXI
 \ 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  Cond: DOES> Line 2484  Cond: DOES>
   
 : 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  Cond: DOES> Line 2529  Cond: DOES>
   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  magic 7 + c! Line 3031  magic 7 + c!
   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  Variable outfile-fd Line 3238  Variable outfile-fd
 : 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

Removed from v.1.109  
changed lines
  Added in v.1.110


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