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

version 1.108, 2001/09/05 11:45:38 version 1.111, 2001/09/06 08:14:16
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 1684  previous Line 1681  previous
   
 : (cm) ( -- addr )  : (cm) ( -- addr )
     T here align H      T here align H
     -1 colon, ;                                 ' (cm) plugin-of colonmark,      -1 prim, ;                                  ' (cm) plugin-of colonmark,
   
 >TARGET  >TARGET
 : compile, ( xt -- )  : compile, ( xt -- )
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 2468  Cond: DOES> Line 2460  Cond: DOES>
 \ 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
   
   ghost                 ( Create-xt do-ghost ghost )    ghost to built 
   to built   
   built >created @ 0= IF    built >created @ 0= IF
     built >created on      built >created on
     ['] prim-resolved built >comp !       ['] prim-resolved built >comp ! 
Line 2493  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 ! 
    >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 2542  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
   
 : by      ( -- do-ghost ) \ Name  : by      ( -- ) \ Name
   Ghost >do:ghost @ do:ghost! ;    Ghost >do:ghost @ do:ghost! ;
   
 : compile: ( do-ghost -- do-ghost [xt] [colon-sys] )  : compile: ( --[xt] [colon-sys] )
 \G defines a compile time action for created words  \G defines a compile time action for created words
 \G by this builder  \G by this builder
   :noname ;    :noname ;
   
 : ;compile ( do-ghost [xt] [colon-sys] -- do-ghost )  : ;compile ( [xt] [colon-sys] -- )
   postpone ;  built >do:ghost @ >comp ! ; immediate    postpone ; built >do:ghost @ >comp ! ; immediate
   
   
 >TARGET  
 \ Variables and Constants                              05dec92py  \ Variables and Constants                              05dec92py
   
 Builder (Constant)  Builder (Constant)
Line 2629  by Create Line 2609  by Create
   
 \ User variables                                       04may94py  \ User variables                                       04may94py
   
 >CROSS  
   
 Variable tup  0 tup !  Variable tup  0 tup !
 Variable tudp 0 tudp !  Variable tudp 0 tudp !
   
Line 2642  Variable tudp 0 tudp ! Line 2620  Variable tudp 0 tudp !
   tup @ tudp @ + T A! H    tup @ tudp @ + T A! H
   tudp @ dup T cell+ H tudp ! ;    tudp @ dup T cell+ H tudp ! ;
   
 >TARGET  
   
 Builder User  Builder User
 Build: 0 u, X , ;Build  Build: 0 u, X , ;Build
 by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO  by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO
Line 2680  DO: ( ghost -- ) ABORT" CROSS: Don't exe Line 2656  DO: ( ghost -- ) ABORT" CROSS: Don't exe
   
 \ Sturctures                                           23feb95py  \ Sturctures                                           23feb95py
   
 >CROSS  
 : nalign ( addr1 n -- addr2 )  : nalign ( addr1 n -- addr2 )
 \ addr2 is the aligned version of addr1 wrt the alignment size n  \ addr2 is the aligned version of addr1 wrt the alignment size n
  1- tuck +  swap invert and ;   1- tuck +  swap invert and ;
 >TARGET  
   
 Builder (Field)  Builder (Field)
 Build: ;Build  Build: ;Build
Line 2696  Build: ( align1 offset1 align size "name Line 2671  Build: ( align1 offset1 align size "name
     + >r nalign r> ;Build      + >r nalign r> ;Build
 by (Field)  by (Field)
   
   >TARGET
 : struct  T 1 chars 0 H ;  : struct  T 1 chars 0 H ;
 : end-struct  T 2Constant H ;  : end-struct  T 2Constant H ;
   
 : cell% ( n -- size align )  : cell% ( n -- size align )
     T 1 cells H dup ;      T 1 cells H dup ;
   >CROSS
   
 \ Input-Methods                                            01py  \ Input-Methods                                            01py
   
Line 2726  DO:  abort" Not in cross mode" ;DO Line 2703  DO:  abort" Not in cross mode" ;DO
   
 T has? peephole H [IF]  T has? peephole H [IF]
   
 : (cc) compile call T >body a, H ;              ' (cc) IS colon,  >CROSS
   : (callc) compile call T >body a, H ;           ' (callc) plugin-of colon,
   
   \ if we want this, we have to spilt aconstant
   \ and constant!!
   \ Builder (Constant)
   \ compile: g>body X @ lit, ;compile
   
 Builder (Constant)  Builder (Constant)
 compile: g>body X @ lit, ;compile  compile: g>body alit, compile @ ;compile
   
 Builder (Value)  Builder (Value)
 compile: g>body alit, compile @ ;compile  compile: g>body alit, compile @ ;compile
Line 3048  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 3102  Create name-buf 200 chars allot Line 3085  Create name-buf 200 chars allot
   THEN    THEN
   @nb ;    @nb ;
   
   \ FIXME why disabled?!
 : label-from-ghostnameXX ( ghost -- addr len )  : label-from-ghostnameXX ( ghost -- addr len )
 \ same as (label-from-ghostname) but caches generated names  \ same as (label-from-ghostname) but caches generated names
   dup >asm-name @ ?dup IF nip count EXIT THEN    dup >asm-name @ ?dup IF nip count EXIT THEN
Line 3255  Variable outfile-fd Line 3239  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
Line 3268  Variable outfile-fd Line 3250  Variable outfile-fd
 \ \ [IF] [ELSE] [THEN] ...                              14sep97jaw  \ \ [IF] [ELSE] [THEN] ...                              14sep97jaw
   
 \ it is useful to define our own structures and not to rely  \ it is useful to define our own structures and not to rely
 \ on the words in the compiler  \ on the words in the host system
 \ The words in the compiler might be defined with vocabularies  \ The words in the host system might be defined with vocabularies
 \ this doesn't work with our self-made compile-loop  \ this doesn't work with our self-made compile-loop
   
 Create parsed 20 chars allot    \ store word we parsed  Create parsed 20 chars allot    \ store word we parsed

Removed from v.1.108  
changed lines
  Added in v.1.111


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