Diff for /gforth/cross.fs between versions 1.43 and 1.50

version 1.43, 1997/02/08 22:58:09 version 1.50, 1997/07/06 15:42:22
Line 37 Line 37
 \             targets                         09jun93jaw  \             targets                         09jun93jaw
 \       added: 2user and value                11jun93jaw  \       added: 2user and value                11jun93jaw
   
   \       needed? works better now!!!             01mar97jaw
   \       mach file is only loaded into target
   \       cell corrected
   
   
 \ include other.fs       \ ansforth extentions for cross  \ include other.fs       \ ansforth extentions for cross
   
 : string, ( c-addr u -- )  : string, ( c-addr u -- )
Line 93  H Line 98  H
   
 \ Parameter for target systems                         06oct92py  \ Parameter for target systems                         06oct92py
   
   >TARGET
 mach-file count included  mach-file count included
   
   [IFUNDEF] has-interpreter true CONSTANT has-interpreter [THEN]
   
 also Forth definitions  also Forth definitions
   
 [IFDEF] asm-include asm-include [THEN]  [IFDEF] asm-include asm-include [THEN]
   
 previous  previous
   hex
   
 >CROSS  >CROSS
   
 \ Variables                                            06oct92py  
   
 Variable image  
 Variable tlast    NIL tlast !  \ Last name field  
 Variable tlastcfa \ Last code field  
 Variable tdoes    \ Resolve does> calls  
 Variable bit$  
 Variable tdp  
 : there  tdp @ ;  
   
 \ Create additional parameters                         19jan95py  \ Create additional parameters                         19jan95py
   
 T  T
   NIL                Constant TNIL
 cell               Constant tcell  cell               Constant tcell
 cell<<             Constant tcell<<  cell<<             Constant tcell<<
 cell>bit           Constant tcell>bit  cell>bit           Constant tcell>bit
Line 124  float              Constant tfloat Line 124  float              Constant tfloat
 1 bits/byte lshift Constant maxbyte  1 bits/byte lshift Constant maxbyte
 H  H
   
   \ Variables                                            06oct92py
   
   Variable image
   Variable tlast    TNIL tlast !  \ Last name field
   Variable tlastcfa \ Last code field
   Variable tdoes    \ Resolve does> calls
   Variable bit$
   Variable tdp
   : there  tdp @ ;
   
   
 >TARGET  >TARGET
   
 \ Byte ordering and cell size                          06oct92py  \ Byte ordering and cell size                          06oct92py
Line 131  H Line 142  H
 : cell+         tcell + ;  : cell+         tcell + ;
 : cells         tcell<< lshift ;  : cells         tcell<< lshift ;
 : chars         ;  : chars         ;
   : char+         1 + ;
 : floats        tfloat * ;  : floats        tfloat * ;
           
 >CROSS  >CROSS
 : cell/         tcell<< rshift ;  : cell/         tcell<< rshift ;
 >TARGET  >TARGET
 20 CONSTANT bl  20 CONSTANT bl
 -1 Constant NIL  TNIL Constant NIL
   
 >CROSS  >CROSS
   
Line 173  bigendian Line 185  bigendian
   
 >MINIMAL  >MINIMAL
 : makekernel ( targetsize -- targetsize )  : makekernel ( targetsize -- targetsize )
   bit$  over 1- cell>bit rshift 1+ initmem    bit$  over 1- tcell>bit rshift 1+ initmem
   image over initmem tdp off ;    image over initmem tdp off ;
   
 >CROSS  >CROSS
Line 191  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 203  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 \ Target memory access                                 06oct92py  \ Target memory access                                 06oct92py
   
 : align+  ( taddr -- rest )  : align+  ( taddr -- rest )
     cell tuck 1- and - [ cell 1- ] Literal and ;      tcell tuck 1- and - [ tcell 1- ] Literal and ;
 : cfalign+  ( taddr -- rest )  : cfalign+  ( taddr -- rest )
     \ see kernel.fs:cfaligned      \ see kernel.fs:cfaligned
     /maxalign tuck 1- and - [ /maxalign 1- ] Literal and ;      /maxalign tuck 1- and - [ /maxalign 1- ] Literal and ;
Line 219  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 231  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
   
 : here  ( -- there )    there ;  : here  ( -- there )    there ;
 : allot ( n -- )        tdp +! ;  : allot ( n -- )        tdp +! ;
 : ,     ( w -- )        T here H cell T allot  ! H ;  : ,     ( w -- )        T here H tcell T allot  ! H ;
 : c,    ( char -- )     T here    1 allot c! H ;  : c,    ( char -- )     T here    1 allot c! H ;
 : align ( -- )          T here H align+ 0 ?DO  bl T c, H LOOP ;  : align ( -- )          T here H align+ 0 ?DO  bl T c, H LOOP ;
 : cfalign ( -- )  : cfalign ( -- )
Line 245  VARIABLE VocTemp Line 257  VARIABLE VocTemp
 : <T  get-current VocTemp ! also Ghosts definitions ;  : <T  get-current VocTemp ! also Ghosts definitions ;
 : T>  previous VocTemp @ set-current ;  : T>  previous VocTemp @ set-current ;
   
   hex
 4711 Constant <fwd>             4712 Constant <res>  4711 Constant <fwd>             4712 Constant <res>
 4713 Constant <imm>             4714 Constant <do:>  4713 Constant <imm>             4714 Constant <do:>
   
Line 269  Variable last-ghost Line 282  Variable last-ghost
   here tuck swap ! ghostheader T>    here tuck swap ! ghostheader T>
   DOES> dup last-ghost ! >exec @ execute ;    DOES> dup last-ghost ! >exec @ execute ;
   
   variable cfalist 0 cfalist !
   
   : markcfa
     cfalist here over @ , swap ! , ;
   
 \ ghost words                                          14oct92py  \ ghost words                                          14oct92py
 \                                          changed:    10may93py/jaw  \                                          changed:    10may93py/jaw
   
Line 338  variable ResolveFlag Line 356  variable ResolveFlag
   WHILE dup ?resolved    WHILE dup ?resolved
   REPEAT drop ResolveFlag @    REPEAT drop ResolveFlag @
   IF    IF
       abort" Unresolved words!"        -1 abort" Unresolved words!"
   ELSE    ELSE
       ." Nothing!"        ." Nothing!"
   THEN    THEN
Line 374  VARIABLE ^imm Line 392  VARIABLE ^imm
   
 \ Target Document Creation (goes to crossdoc.fd)       05jul95py  \ Target Document Creation (goes to crossdoc.fd)       05jul95py
   
 s" crossdoc.fd" r/w create-file throw value doc-file-id  s" doc/crossdoc.fd" r/w create-file throw value doc-file-id
 \ contains the file-id of the documentation file  \ contains the file-id of the documentation file
   
 : T-\G ( -- )  : T-\G ( -- )
Line 441  Defer skip? ' false IS skip? Line 459  Defer skip? ' false IS skip?
     ghost >magic @ <fwd> <> ;      ghost >magic @ <fwd> <> ;
   
 : needed? ( -- flag ) \ name  : needed? ( -- flag ) \ name
     ghost dup >magic @ <fwd> =  \G returns a false flag when
     IF  >link @ 0<>  ELSE  drop false  THEN ;  \G a word is not defined
   \G a forward reference exists
   \G so the definition is not skipped!
       bl word gfind
       IF dup >magic @ <fwd> = 
           \ swap >link @ 0<> and 
           nip
           0=
       ELSE  drop true  THEN ;
   
   : doer? ( -- flag ) \ name
       ghost >magic @ <do:> = ;
   
 : skip-defs ( -- )  : skip-defs ( -- )
     BEGIN  refill  WHILE  source -trailing nip 0= UNTIL  THEN ;      BEGIN  refill  WHILE  source -trailing nip 0= UNTIL  THEN ;
Line 525  ghost (does>)   ghost noop Line 554  ghost (does>)   ghost noop
 ghost (.")      ghost (S")      ghost (ABORT")  2drop drop  ghost (.")      ghost (S")      ghost (ABORT")  2drop drop
 ghost '                                         drop  ghost '                                         drop
 ghost :docol    ghost :doesjump ghost :dodoes   2drop drop  ghost :docol    ghost :doesjump ghost :dodoes   2drop drop
   ghost over      ghost =         ghost drop      2drop drop
   
 \ compile                                              10may93jaw  \ compile                                              10may93jaw
   
Line 539  ghost :docol    ghost :doesjump ghost :d Line 569  ghost :docol    ghost :doesjump ghost :d
 \ generic threading modell  \ generic threading modell
 : docol,  ( -- ) compile :docol T 0 , H ;  : docol,  ( -- ) compile :docol T 0 , H ;
   
 : dodoes, ( -- ) compile :doesjump T 0 , H ;  : dodoes, ( -- ) T cfalign H compile :doesjump T 0 , H ;
   
 [IFUNDEF] (code)   [IFUNDEF] (code) 
 Defer (code)  Defer (code)
 Defer (end-code)  Defer (end-code)
 [THEN]  [THEN]
   
   [IFUNDEF] ca>native
   defer ca>native
   [THEN]
   
 >TARGET  >TARGET
 : Code  : Code
     (THeader there resolve    (THeader there resolve
     there 2 T cells H + T a, 0 , H    [ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF]
     depth (code) ;    there 2 T cells H + ca>native T a, 0 , H
     [THEN]
     depth (code) ;
   
 : Code:  : Code:
     ghost dup there resolve  <do:> swap >magic !      ghost dup there ca>native resolve  <do:> swap >magic !
     depth (code) ;      depth (code) ;
   
 : end-code  : end-code
Line 644  Cond: MAXI Line 680  Cond: MAXI
   docol, depth T ] H ;    docol, depth T ] H ;
   
 : :noname ( -- colon-sys )  : :noname ( -- colon-sys )
   T align H there docol, depth T ] H ;    T cfalign H there docol, depth T ] H ;
   
 Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond  Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond
   
Line 686  Cond: DOES> restrict? Line 722  Cond: DOES> restrict?
         dup >magic @ <do:> =          dup >magic @ <do:> =
         IF  gexecute T 0 , H  EXIT THEN          IF  gexecute T 0 , H  EXIT THEN
     THEN      THEN
     compile :dodoes gexecute T here H cell - reloff ;      compile :dodoes gexecute T here H tcell - reloff ;
   
 : TCreate ( -- )  : TCreate ( -- )
   last-ghost @    last-ghost @
Line 760  Build: T 0 au, , H ; Line 796  Build: T 0 au, , H ;
 by User  by User
 Builder AUser  Builder AUser
   
 Build:  ( n -- ) T , H ;  Build:  ( n -- ) ;
 by: :docon ( ghost -- n ) T @ H ;DO  by: :docon ( ghost -- n ) T @ H ;DO
   Builder (Constant)
   
   Build:  ( n -- ) T , H ;
   by (Constant)
 Builder Constant  Builder Constant
   
 Build:  ( n -- ) T A, H ;  Build:  ( n -- ) T A, H ;
 by Constant  by (Constant)
 Builder AConstant  Builder AConstant
   
 Build:  ( d -- ) T , , H ;  Build:  ( d -- ) T , , H ;
 DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO  DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
 Builder 2Constant  Builder 2Constant
   
 Build: T 0 , H ;  Build: T , H ;
 by Constant  by (Constant)
 Builder Value  Builder Value
   
 Build: T 0 A, H ;  Build: T A, H ;
 by Constant  by (Constant)
 Builder AValue  Builder AValue
   
 Build:  ( -- ) compile noop ;  Build:  ( -- ) compile noop ;
Line 796  Builder interpret/compile: Line 836  Builder interpret/compile:
  1- tuck +  swap invert and ;   1- tuck +  swap invert and ;
 >TARGET  >TARGET
   
   Build: ;
   by: :dofield T @ H + ;DO
   Builder (Field)
   
 Build:  >r rot r@ nalign  dup T , H  ( align1 size offset )  Build:  >r rot r@ nalign  dup T , H  ( align1 size offset )
         + swap r> nalign ;          + swap r> nalign ;
 by: :dofield T @ H + ;DO  by (Field)
 Builder Field  Builder Field
   
 : struct  T 0 1 chars H ;  : struct  T 0 1 chars H ;
Line 853  Cond: AGAIN     restrict? sys? compile b Line 897  Cond: AGAIN     restrict? sys? compile b
 Cond: UNTIL     restrict? sys? compile ?branch <resolve ;Cond  Cond: UNTIL     restrict? sys? compile ?branch <resolve ;Cond
 Cond: REPEAT    restrict? over 0= ?struc compile AGAIN compile THEN ;Cond  Cond: REPEAT    restrict? over 0= ?struc compile AGAIN compile THEN ;Cond
   
   Cond: CASE      restrict? 0 ;Cond
   Cond: OF        restrict? 1+ >r compile over compile = compile IF compile drop
                   r> ;Cond
   Cond: ENDOF     restrict? >r compile ELSE r> ;Cond
   Cond: ENDCASE   restrict? compile drop 0 ?DO  compile THEN  LOOP ;Cond
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 Cond: DO        restrict? compile (do)   T here H ;Cond  Cond: DO        restrict? compile (do)   T here H ;Cond
 Cond: ?DO       restrict? compile (?do)  (leave T here H ;Cond  Cond: ?DO       restrict? compile (?do)  T (leave here H ;Cond
 Cond: FOR       restrict? compile (for)  T here H ;Cond  Cond: FOR       restrict? compile (for)  T here H ;Cond
   
 >CROSS  >CROSS
 : loop]   dup <resolve cell - compile DONE compile unloop ;  : loop]   dup <resolve tcell - compile DONE compile unloop ;
 >TARGET  >TARGET
   
 Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond  Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond
Line 920  also minimal Line 970  also minimal
 \ define new [IFDEF] and [IFUNDEF]                      20may93jaw  \ define new [IFDEF] and [IFUNDEF]                      20may93jaw
   
 : defined? defined? ;  : defined? defined? ;
   : needed? needed? ;
   : doer? doer? ;
   
 : [IFDEF] defined? postpone [IF] ;  : [IFDEF] defined? postpone [IF] ;
 : [IFUNDEF] defined? 0= postpone [IF] ;  : [IFUNDEF] defined? 0= postpone [IF] ;
Line 938  also minimal Line 990  also minimal
   
 also minimal  also minimal
   
   \G interprets the line if word is not defined
 : \- defined? IF postpone \ THEN ;  : \- defined? IF postpone \ THEN ;
   
   \G interprets the line if word is defined
 : \+ defined? 0= IF postpone \ THEN ;  : \+ defined? 0= IF postpone \ THEN ;
   
   Cond: \- \- ;Cond
   Cond: \+ \+ ;Cond
   
   : ?? bl word find IF execute ELSE drop 0 THEN ;
   
   : needed:
   \G defines ghost for words that we want to be compiled
     BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;
   
 : [IF]   postpone [IF] ;  : [IF]   postpone [IF] ;
 : [THEN] postpone [THEN] ;  : [THEN] postpone [THEN] ;
 : [ELSE] postpone [ELSE] ;  : [ELSE] postpone [ELSE] ;
Line 951  Cond: [IFUNDEF] [IFUNDEF] ;Cond Line 1015  Cond: [IFUNDEF] [IFUNDEF] ;Cond
 Cond: [THEN]    [THEN] ;Cond  Cond: [THEN]    [THEN] ;Cond
 Cond: [ELSE]    [ELSE] ;Cond  Cond: [ELSE]    [ELSE] ;Cond
   
 \ save-cross                                           17mar93py  previous
   
 \ i'm not interested in bigforth features this time    10may93jaw  
 \ [IFDEF] file  
 \ also file  
 \ [THEN]  
 \ included throw after create-file                     11may93jaw  
   
 bigendian Constant bigendian  \ save-cross                                           17mar93py
   
   >CROSS
 Create magic  s" Gforth10" here over allot swap move  Create magic  s" Gforth10" here over allot swap move
   
 char 1 bigendian + cell + magic 7 + c!  char 1 bigendian + tcell + magic 7 + c!
   
 : save-cross ( "image-name" "binary-name" -- )  : save-cross ( "image-name" "binary-name" -- )
   bl parse ." Saving to " 2dup type cr    bl parse ." Saving to " 2dup type cr
   w/o bin create-file throw >r    w/o bin create-file throw >r
   NIL IF    TNIL IF
       s" #! "   r@ write-file throw        s" #! "   r@ write-file throw
       bl parse  r@ write-file throw        bl parse  r@ write-file throw
       s"  -i"   r@ write-file throw        s"  -i"   r@ write-file throw
Line 983  char 1 bigendian + cell + magic 7 + c! Line 1042  char 1 bigendian + cell + magic 7 + c!
       bl parse 2drop        bl parse 2drop
   THEN    THEN
   image @ there r@ write-file throw \ write image    image @ there r@ write-file throw \ write image
   NIL IF    TNIL IF
       bit$  @ there 1- cell>bit rshift 1+        bit$  @ there 1- tcell>bit rshift 1+
                 r@ write-file throw \ write tags                  r@ write-file throw \ write tags
   THEN    THEN
   r> close-file throw ;    r> close-file throw ;
   
 \ words that should be in minimal  \ words that should be in minimal
   >MINIMAL
   also minimal
   
   bigendian Constant bigendian
   : save-cross save-cross ;
 : here there ;  : here there ;
 also forth [IFDEF] Label : Label Label ; [THEN] previous  also forth 
   [IFDEF] Label : Label Label ; [THEN] 
   [IFDEF] start-macros : start-macros start-macros ; [THEN]
   previous
   
 : + + ;  : + + ;
 : or or ;  : or or ;
 : 1- 1- ;  : 1- 1- ;
Line 1010  also forth [IFDEF] Label : Label Label ; Line 1077  also forth [IFDEF] Label : Label Label ;
 : lshift lshift ;  : lshift lshift ;
 : 2/ 2/ ;  : 2/ 2/ ;
 : . . ;  : . . ;
   : const ;
   
 mach-file count included  \ mach-file count included
   
 : all-words    ['] false    IS skip? ;  : all-words    ['] false    IS skip? ;
 : needed-words ['] needed?  IS skip? ;  : needed-words ['] needed?  IS skip? ;
 : undef-words  ['] defined? IS skip? ;  : undef-words  ['] defined? IS skip? ;
   
 : \  postpone \ ;  immediate  : \  postpone \ ;  immediate
   : \G T-\G ; immediate
 : (  postpone ( ;  immediate  : (  postpone ( ;  immediate
 : include bl word count included ;  : include bl word count included ;
 : .( [char] ) parse type ;  : .( [char] ) parse type ;

Removed from v.1.43  
changed lines
  Added in v.1.50


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