Diff for /gforth/cross.fs between versions 1.55 and 1.75

version 1.55, 1998/05/31 19:29:22 version 1.75, 1999/05/10 13:57:37
Line 1 Line 1
 \ CROSS.FS     The Cross-Compiler                      06oct92py  \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
   
 \ Copyright (C) 1995 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 19 Line 19
 \ along with this program; if not, write to the Free Software  \ along with this program; if not, write to the Free Software
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   
 \ Log:  0 
 \       changed in ; [ to state off           12may93jaw  [IF]
 \       included place +place                 12may93jaw  
 \       for a created word (variable, constant...)  ToDo:
 \       is now an alias in the target voabulary.  Crossdoc destination ./doc/crossdoc.fd makes no sense when
 \       this means it is no longer necessary to  cross.fs is uses seperately. jaw
 \       switch between vocabularies for variable  Do we need this char translation with >address and in branchoffset? 
 \       initialization                        12may93jaw  (>body also affected) jaw
 \       discovered error in DOES>  Clean up mark> and >resolve stuff jaw
 \       replaced !does with (;code)           16may93jaw  
 \       made complete redesign and  [THEN]
 \       introduced two vocs method  
 \       to be asure that the right words  
 \       are found                             08jun93jaw  
 \       btw:  ! works not with 16 bit  
 \             targets                         09jun93jaw  
 \       added: 2user and value                11jun93jaw  
   
 \       needed? works better now!!!             01mar97jaw  
 \       mach file is only loaded into target  
 \       cell corrected  
 \       romable extansions                      27apr97-5jun97jaw  
 \       environmental query support             01sep97jaw  
 \       added own [IF] ... [ELSE] ... [THEN]    14sep97jaw  
 \       extra resolver for doers                20sep97jaw  
 \       added killref for DOES>                 20sep97jaw  
   
   
 hex     \ the defualt base for the cross-compiler is hex !!  hex     \ the defualt base for the cross-compiler is hex !!
Line 52  Warnings off Line 37  Warnings off
   
 \ words that are generaly useful  \ words that are generaly useful
   
   : KB  400 * ;
 : >wordlist ( vocabulary-xt -- wordlist-struct )  : >wordlist ( vocabulary-xt -- wordlist-struct )
   also execute get-order swap >r 1- set-order r> ;    also execute get-order swap >r 1- set-order r> ;
   
Line 66  Warnings off Line 52  Warnings off
 \G Same behaviour as "Value" if the <name> is not defined  \G Same behaviour as "Value" if the <name> is not defined
 \G Same behaviour as "to" if <name> is defined  \G Same behaviour as "to" if <name> is defined
 \G SetValue searches in the current vocabulary  \G SetValue searches in the current vocabulary
  save-input bl word >r restore-input throw r> count    save-input bl word >r restore-input throw r> count
  get-current search-wordlist    get-current search-wordlist
  IF bl word drop >body ! ELSE Value THEN ;    IF    drop >r
           \ we have to set current to be topmost context wordlist
           get-order get-order get-current swap 1+ set-order
           r> ['] to execute
           set-order
     ELSE Value THEN ;
   
 : DefaultValue ( n -- <name> )  : DefaultValue ( n -- <name> )
 \G Same behaviour as "Value" if the <name> is not defined  \G Same behaviour as "Value" if the <name> is not defined
 \G DefaultValue searches in the current vocabulary  \G DefaultValue searches in the current vocabulary
  save-input bl word >r restore-input throw r> count   save-input bl word >r restore-input throw r> count
  get-current search-wordlist   get-current search-wordlist
  IF bl word drop drop drop ELSE Value THEN ;   IF bl word drop 2drop ELSE Value THEN ;
   
 hex  hex
   
Line 127  also forth definitions  \ these values m Line 118  also forth definitions  \ these values m
 false DefaultValue stack-warn            \ check on empty stack at any definition  false DefaultValue stack-warn            \ check on empty stack at any definition
 false DefaultValue create-forward-warn   \ warn on forward declaration of created words  false DefaultValue create-forward-warn   \ warn on forward declaration of created words
   
 [IFUNDEF] DebugMaskSrouce Variable DebugMaskSource 0 DebugMaskSource ! [THEN]  
 [IFUNDEF] DebugMaskCross  Variable DebugMaskCross  0 DebugMaskCross  ! [THEN]  
     
   
 previous >CROSS  previous >CROSS
   
Line 152  stack-warn [IF] Line 144  stack-warn [IF]
 : defempty? ; immediate  : defempty? ; immediate
 [THEN]  [THEN]
   
   \ debugging
   
   0 [IF]
   
   This implements debugflags for the cross compiler and the compiled
   images. It works identical to the has-flags in the environment.
   The debugflags are defined in a vocabluary. If the word exists and
   its value is true, the flag is switched on.
   
   [THEN]
   
   Vocabulary debugflags   \ debug flags for cross
   also debugflags get-order over
   Constant debugflags-wl
   set-order previous
   
   : DebugFlag
     get-current >r debugflags-wl set-current
     SetValue
     r> set-current ;
   
   : Debug? ( adr u -- flag )
   \G return true if debug flag is defined or switched on
     debugflags-wl search-wordlist
     IF EXECUTE
     ELSE false THEN ;
   
   : D? ( <name> -- flag )
   \G return true if debug flag is defined or switched on
   \G while compiling we do not return the current value but
     bl word count debug? ;
   
   : [d?]
   \G compile the value-xt so the debug flag can be switched
   \G the flag must exist!
     bl word count debugflags-wl search-wordlist
     IF    compile,
     ELSE  -1 ABORT" unknown debug flag"
           \ POSTPONE false 
     THEN ; immediate
   
 \ \ GhostNames Ghosts                                  9may93jaw  \ \ GhostNames Ghosts                                  9may93jaw
   
Line 180  VARIABLE VocTemp Line 211  VARIABLE VocTemp
 hex  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:>
   4715 Constant <skip>
   
 \ iForth makes only immediate directly after create  \ iForth makes only immediate directly after create
 \ make atonce trick! ?  \ make atonce trick! ?
Line 249  VARIABLE Already Line 281  VARIABLE Already
 : forward? ( ghost -- flag )  : forward? ( ghost -- flag )
   >magic @ <fwd> = ;    >magic @ <fwd> = ;
   
   : undefined? ( ghost -- flag )
     >magic @ dup <fwd> = swap <skip> = or ;
   
 \ Predefined ghosts                                    12dec92py  \ Predefined ghosts                                    12dec92py
   
 ghost 0=                                        drop  ghost 0=                                        drop
Line 281  VARIABLE env-current \ save information Line 316  VARIABLE env-current \ save information
   
 >TARGET  >TARGET
   
 : environment?  : environment? ( adr len -- [ x ] true | false )
   target-environment search-wordlist     target-environment search-wordlist 
   IF execute true ELSE false THEN ;    IF execute true ELSE false THEN ;
   
 : e? name T environment? H 0= ABORT" environment variable not defined!" ;  : e? bl word count T environment? H 0= ABORT" environment variable not defined!" ;
   
 : has?  name T environment? H   : has?  bl word count T environment? H 
         IF      \ environment variable is present, return its value          IF      \ environment variable is present, return its value
         ELSE    \ environment variable is not present, return false          ELSE    \ environment variable is not present, return false
                 \ !! JAW abort is just for testing                  false \ debug true ABORT" arg" 
                 false true ABORT" arg"   
         THEN ;          THEN ;
   
 : $has? T environment? H IF ELSE false THEN ;  : $has? T environment? H IF ELSE false THEN ;
Line 302  true  SetValue cross Line 336  true  SetValue cross
 true SetValue standard-threading  true SetValue standard-threading
 >TARGET previous  >TARGET previous
   
   
 mach-file count included hex  mach-file count included hex
   
 >ENVIRON  >ENVIRON
Line 323  false DefaultValue header Line 358  false DefaultValue header
 true DefaultValue interpreter  true DefaultValue interpreter
 true DefaultValue ITC  true DefaultValue ITC
 false DefaultValue rom  false DefaultValue rom
   true DefaultValue standardthreading
   
 >TARGET  >TARGET
 s" relocate" T environment? H   s" relocate" T environment? H 
Line 334  s" relocate" T environment? H Line 370  s" relocate" T environment? H
   
 \ \ Create additional parameters                         19jan95py  \ \ Create additional parameters                         19jan95py
   
   \ currently cross only works for host machines with address-unit-bits
   \ eual to 8 because of s! and sc!
   \ but I start to query the environment just to modularize a little bit
   
   : check-address-unit-bits ( -- )        
   \       s" ADDRESS-UNIT-BITS" environment?
   \       IF 8 <> ELSE true THEN
   \       ABORT" ADDRESS-UNIT-BITS unknown or not equal to 8!"
   
   \       shit, this doesn't work because environment? is only defined for 
   \       gforth.fi and not kernl???.fi
           ;
   
   check-address-unit-bits
   8 Constant bits/byte    \ we define: byte is address-unit
   
   1 bits/byte lshift Constant maxbyte 
   \ this sets byte size for the target machine, an (probably right guess) jaw
   
 T  T
 NIL                Constant TNIL  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
 bits/byte          Constant tbits/byte  bits/char               Constant tbits/char
 float              Constant tfloat  bits/char H bits/byte T /      
 1 bits/byte lshift Constant maxbyte                          Constant tchar
   float                   Constant tfloat
   1 bits/char lshift      Constant tmaxchar
   [IFUNDEF] bits/byte
   8                       Constant tbits/byte
   [ELSE]
   bits/byte               Constant tbits/byte
   [THEN]
 H  H
   tbits/byte bits/byte /  Constant tbyte
   
   
 \ Variables                                            06oct92py  \ Variables                                            06oct92py
   
Line 357  Variable bit$ Line 421  Variable bit$
 Variable headers-named 0 headers-named !  Variable headers-named 0 headers-named !
 Variable user-vars 0 user-vars !  Variable user-vars 0 user-vars !
   
 \ Memory initialisation                                05dec92py  : target>bitmask-size ( u1 -- u2 )
     1- tcell>bit rshift 1+ ;
 [IFDEF] Memory \ Memory is a bigFORTH feature  
    also Memory  
    : initmem ( var len -- )  
      2dup swap handle! >r @ r> erase ;  
    toss  
 [ELSE]  
    : initmem ( var len -- )  
      tuck allocate abort" CROSS: No memory for target"  
      ( len var adr ) dup rot !  
      ( len adr ) swap erase ;  
 [THEN]  
   
 \ MakeKernal                                           12dec92py  : allocatetarget ( size --- adr )
     dup allocate ABORT" CROSS: No memory for target"
 : makekernel ( targetsize -- targetsize )    swap over swap erase ;
   bit$  over 1- tcell>bit rshift 1+ initmem  
   image over initmem ;  
   
 >MINIMAL  
 : makekernel makekernel ;  
   
   
 >CROSS  
   
 \ \ memregion.fs  \ \ memregion.fs
   
Line 392  Variable mirrored-link          \ linked Line 437  Variable mirrored-link          \ linked
 0 dup mirrored-link ! region-link !  0 dup mirrored-link ! region-link !
   
   
   : >rname 6 cells + ;
   : >rbm   5 cells + ;
   : >rmem  4 cells + ;
   : >rlink 3 cells + ;
 : >rdp 2 cells + ;  : >rdp 2 cells + ;
 : >rlen cell+ ;  : >rlen cell+ ;
 : >rstart ;  : >rstart ;
Line 405  Variable mirrored-link          \ linked Line 454  Variable mirrored-link          \ linked
         save-input create restore-input throw          save-input create restore-input throw
         here last-defined-region !          here last-defined-region !
         over ( startaddr ) , ( length ) , ( dp ) ,          over ( startaddr ) , ( length ) , ( dp ) ,
         region-link linked name string,          region-link linked 0 , 0 , bl word count string,
   ELSE  \ store new parameters in region    ELSE  \ store new parameters in region
         bl word drop          bl word drop
         >body >r r@ last-defined-region !          >body >r r@ last-defined-region !
         r@ cell+ ! dup r@ ! r> 2 cells + !          r@ >rlen ! dup r@ >rstart ! r> >rdp !
   THEN ;    THEN ;
   
 : borders ( region -- startaddr endaddr ) \G returns lower and upper region border  : borders ( region -- startaddr endaddr ) \G returns lower and upper region border
   dup @ swap cell+ @ over + ;    dup >rstart @ swap >rlen @ over + ;
   
 : extent  ( region -- startaddr len )   \G returns the really used area  : extent  ( region -- startaddr len )   \G returns the really used area
   dup @ swap 2 cells + @ over - ;    dup >rstart @ swap >rdp @ over - ;
   
 : area ( region -- startaddr totallen ) \G returns the total area  : area ( region -- startaddr totallen ) \G returns the total area
   dup @ swap cell+ @ ;    dup >rstart swap >rlen @ ;
   
 : mirrored                              \G mark a region as mirrored  : mirrored                              \G mark a region as mirrored
   mirrored-link    mirrored-link
   linked last-defined-region @ , ;    align linked last-defined-region @ , ;
   
 : .addr  : .addr ( u -- )
   \G prints a 16 or 32 Bit nice hex value
   base @ >r hex    base @ >r hex
   tcell 2 u>    tcell 2 u>
   IF s>d <# # # # # '. hold # # # # #> type    IF s>d <# # # # # '. hold # # # # #> type
Line 439  Variable mirrored-link          \ linked Line 489  Variable mirrored-link          \ linked
   0 region-link @    0 region-link @
   BEGIN dup WHILE dup @ REPEAT drop    BEGIN dup WHILE dup @ REPEAT drop
   BEGIN dup    BEGIN dup
   WHILE cr 3 cells - >r    WHILE cr
         r@ 4 cells + count tuck type          0 >rlink - >r
           r@ >rname count tuck type
         12 swap - 0 max spaces space          12 swap - 0 max spaces space
         ." Start: " r@ @ dup .addr space          ." Start: " r@ >rstart @ dup .addr space
         ." End: " r@ 1 cells + @ + .addr space          ." End: " r@ >rlen @ + .addr space
         ." DP: " r> 2 cells + @ .addr           ." DP: " r> >rdp @ .addr
   REPEAT drop    REPEAT drop
   s" rom" T $has? H 0= ?EXIT    s" rom" T $has? H 0= ?EXIT
   cr ." Mirrored:"    cr ." Mirrored:"
   mirrored-link @    mirrored-link @
   BEGIN dup    BEGIN dup
   WHILE space dup cell+ @ 4 cells + count type @    WHILE space dup cell+ @ >rname count type @
   REPEAT drop cr    REPEAT drop cr
   ;    ;
   
Line 482  T has? rom H Line 533  T has? rom H
 : setup-target ( -- )   \G initialize targets memory space  : setup-target ( -- )   \G initialize targets memory space
   s" rom" T $has? H    s" rom" T $has? H
   IF  \ check for ram and rom...    IF  \ check for ram and rom...
       address-space area nip        \ address-space area nip 0<>
       ram-dictionary area nip        ram-dictionary area nip 0<>
       rom-dictionary area nip        rom-dictionary area nip 0<>
       and and 0=        and 0=
       ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!"        ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!"
   THEN    THEN
   address-space area nip    address-space area nip
Line 494  T has? rom H Line 545  T has? rom H
   ELSE    ELSE
       dictionary area        dictionary area
   THEN    THEN
   dup 0=    nip 0=
   ABORT" CROSS: define at least address-space or dictionary!!"    ABORT" CROSS: define at least address-space or dictionary!!"
   + makekernel drop ;  
     \ allocate target for each region
     region-link
     BEGIN @ dup
     WHILE dup
           0 >rlink - >r
           r@ >rlen @
           IF      \ allocate mem
                   r@ >rlen @ dup
   
                   allocatetarget dup image !
                   r@ >rmem !
   
                   target>bitmask-size allocatetarget
                   dup bit$ !
                   r> >rbm !
   
           ELSE    r> drop THEN
      REPEAT drop ;
   
   \ MakeKernal                                                    22feb99jaw
   
   : makekernel ( targetsize -- targetsize )
     dup dictionary >rlen ! setup-target ;
   
   >MINIMAL
   : makekernel makekernel ;
   >CROSS
   
 \ \ switched tdp for rom support                                03jun97jaw  \ \ switched tdp for rom support                                03jun97jaw
   
Line 532  variable fixed  \ flag: true: no automat Line 610  variable fixed  \ flag: true: no automat
   
 variable constflag constflag off  variable constflag constflag off
   
   : activate ( region -- )
   \G next code goes to this region
     >rdp to tdp ;
   
 : (switchram)  : (switchram)
   fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT    fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT
   ram-dictionary >rdp to tdp ;    ram-dictionary activate ;
   
 : switchram  : switchram
   constflag @    constflag @
   IF constflag off ELSE (switchram) THEN ;    IF constflag off ELSE (switchram) THEN ;
   
 : switchrom  : switchrom
   fixed @ ?EXIT rom-dictionary >rdp to tdp ;    fixed @ ?EXIT rom-dictionary activate ;
   
 : >tempdp ( addr -- )   : >tempdp ( addr -- ) 
   tdp tempdp-save ! tempdp to tdp tdp ! ;    tdp tempdp-save ! tempdp to tdp tdp ! ;
Line 557  variable constflag constflag off Line 639  variable constflag constflag off
 \ : romstart dup sromdp ! romdp ! ;  \ : romstart dup sromdp ! romdp ! ;
 \ : ramstart dup sramdp ! ramdp ! ;  \ : ramstart dup sramdp ! ramdp ! ;
   
 \ default compilation goed to rom  \ default compilation goes to rom
 \ when romable support is off, only the rom switch is used (!!)  \ when romable support is off, only the rom switch is used (!!)
 >auto  >auto
   
Line 571  variable constflag constflag off Line 653  variable constflag constflag off
   
 : cell+         tcell + ;  : cell+         tcell + ;
 : cells         tcell<< lshift ;  : cells         tcell<< lshift ;
 : chars         ;  : chars         tchar * ;
 : char+         1 + ;  : char+         tchar + ;
 : floats        tfloat * ;  : floats        tfloat * ;
           
 >CROSS  >CROSS
Line 589  bigendian Line 671  bigendian
      DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
    : S@  ( addr -- n )  >r 0 0 r> tcell bounds     : S@  ( addr -- n )  >r 0 0 r> tcell bounds
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
      : Sc!  ( n addr -- )  >r s>d r> tchar bounds swap 1-
        DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
      : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds
        DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
 [ELSE]  [ELSE]
    : S!  ( n addr -- )  >r s>d r> tcell bounds     : S!  ( n addr -- )  >r s>d r> tcell bounds
      DO  maxbyte ud/mod rot I c!  LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
    : S@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-     : S@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
      : Sc!  ( n addr -- )  >r s>d r> tchar bounds
        DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
      : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds swap 1-
        DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
 [THEN]  [THEN]
   
 >CROSS  : taddr>region ( taddr -- region | 0 )
   \G finds for a target-address the correct region
   \G returns 0 if taddr is not in range of a target memory region
     region-link
     BEGIN @ dup
     WHILE dup >r
           0 >rlink - >r
           r@ >rlen @
           IF      dup r@ borders within
                   IF r> r> drop nip EXIT THEN
           THEN
           r> drop
           r>
     REPEAT
     2drop 0 ;
   
   : (>regionimage) ( taddr -- 'taddr )
     dup
     \ find region we want to address
     taddr>region dup 0= ABORT" Address out of range!"
     >r
     \ calculate offset in region
     r@ >rstart @ -
     \ add regions real address in our memory
     r> >rmem @ + ;
   
 \ Bit string manipulation                               06oct92py  \ Bit string manipulation                               06oct92py
 \                                                       9may93jaw  \                                                       9may93jaw
 CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,  CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
Line 605  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 720  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;  : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
 : +bit ( addr n -- )  >bit over c@ or swap c! ;  : +bit ( addr n -- )  >bit over c@ or swap c! ;
 : -bit ( addr n -- )  >bit invert over c@ and swap c! ;  : -bit ( addr n -- )  >bit invert over c@ and swap c! ;
 : relon ( taddr -- )  bit$ @ swap cell/ +bit ;  
 : reloff ( taddr -- )  bit$ @ swap cell/ -bit ;  : (relon) ( taddr -- )  bit$ @ swap cell/ +bit ;
   : (reloff) ( taddr -- ) bit$ @ swap cell/ -bit ;
   
   : (>image) ( taddr -- absaddr ) image @ + ;
   
   DEFER >image
   DEFER relon
   DEFER reloff
   DEFER correcter
   
   T has? relocate H
   [IF]
   ' (relon) IS relon
   ' (reloff) IS reloff
   ' (>image) IS >image
   [ELSE]
   ' drop IS relon
   ' drop IS reloff
   ' (>regionimage) IS >image
   [THEN]
   
 \ Target memory access                                 06oct92py  \ Target memory access                                 06oct92py
   
Line 624  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 758  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
     \ see kernel.fs      \ see kernel.fs
     dup cfalign+ + ;      dup cfalign+ + ;
   
 >CROSS  
 : >image ( taddr -- absaddr )  image @ + ;  
 >TARGET  
 : @  ( taddr -- w )     >image S@ ;  : @  ( taddr -- w )     >image S@ ;
 : !  ( w taddr -- )     >image S! ;  : !  ( w taddr -- )     >image S! ;
 : c@ ( taddr -- char )  >image c@ ;  : c@ ( taddr -- char )  >image Sc@ ;
 : c! ( char taddr -- )  >image c! ;  : c! ( char taddr -- )  >image Sc! ;
 : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;  : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
 : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;  : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;
   
Line 640  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 771  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 tcell T allot  ! H T here drop H ;  : ,     ( w -- )        T here H tcell T allot  ! H T here drop H ;
 : c,    ( char -- )     T here    1 allot c! H ;  : c,    ( char -- )     T here    tchar 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, tchar H +LOOP ;
 : cfalign ( -- )  : cfalign ( -- )
     T here H cfalign+ 0 ?DO  bl T c, H LOOP ;      T here H cfalign+ 0 ?DO  bl T c, tchar H +LOOP ;
   
 : A!                    dup relon T ! H ;  : >address              dup 0>= IF tbyte / THEN ; \ ?? jaw 
 : A,    ( w -- )        T here H relon T , H ;  : A!                    swap >address swap dup relon T ! H ;
   : A,    ( w -- )        >address T here H relon T , H ;
   
 >CROSS  >CROSS
   
 : tcmove ( source dest len -- )  : tcmove ( source dest len -- )
 \G cmove in target memory  \G cmove in target memory
   bounds    tchar * bounds
   ?DO  dup T c@ H I T c! H 1+    ?DO  dup T c@ H I T c! H 1+
   LOOP  drop ;    tchar +LOOP  drop ;
   
   \ \ Load Assembler
   
 >TARGET  >TARGET
 H also Forth definitions \ ." asm: " order  H also Forth definitions
   
 : X     also target bl word find  : X     also target bl word find
         IF      state @ IF compile,          IF      state @ IF compile,
Line 753  DEFER comp[     \ ends compilation Line 887  DEFER comp[     \ ends compilation
 : >fl-name 2 cells + ;  : >fl-name 2 cells + ;
   
 Variable filelist 0 filelist !  Variable filelist 0 filelist !
   Create NoFile ," #load-file#"
 0 Value  filemem  0 Value  filemem
 : loadfile filemem >fl-name ;  : loadfile  FileMem ?dup IF >fl-name ELSE NoFile THEN ;
   
 1 [IF] \ !! JAW WIP  1 [IF] \ !! JAW WIP
   
Line 774  Variable filelist 0 filelist ! Line 909  Variable filelist 0 filelist !
         REPEAT          REPEAT
         2drop drop false ;                2drop drop false ;      
   
   false DebugFlag showincludedfiles
   
 : included   : included 
 \       cr ." Including: " 2dup type ." ..."          [d?] showincludedfiles
           IF      cr ." Including: " 2dup type ." ..." THEN
         FileMem >r          FileMem >r
         2dup add-included-file included           2dup add-included-file included 
         r> to FileMem ;          r> to FileMem ;
Line 878  Exists-Warnings on Line 1016  Exists-Warnings on
 \G resolve referencies to ghost with tcfa  \G resolve referencies to ghost with tcfa
     \ is ghost resolved?, second resolve means another definition with the      \ is ghost resolved?, second resolve means another definition with the
     \ same name      \ same name
     over forward? 0= IF  exists EXIT THEN      over undefined? 0= IF  exists EXIT THEN
     \ get linked-list      \ get linked-list
     swap >r r@ >link @ swap \ ( list tcfa R: ghost )      swap >r r@ >link @ swap \ ( list tcfa R: ghost )
     \ mark ghost as resolved      \ mark ghost as resolved
Line 1055  Create tag-bof 1 c,  0C c, Line 1193  Create tag-bof 1 c,  0C c,
   
 Defer skip? ' false IS skip?  Defer skip? ' false IS skip?
   
   : skipdef ( <name> -- )
   \G skip definition of an undefined word in undef-words mode
       ghost dup forward?
       IF  >magic <skip> swap !
       ELSE drop THEN ;
   
 : defined? ( -- flag ) \ name  : defined? ( -- flag ) \ name
       ghost undefined? 0= ;
   
   : defined2? ( -- flag ) \ name
   \G return true for anything else than forward, even for <skip>
   \G that's what we want
     ghost forward? 0= ;      ghost forward? 0= ;
   
 : needed? ( -- flag ) \ name  : needed? ( -- flag ) \ name
Line 1064  Defer skip? ' false IS skip? Line 1213  Defer skip? ' false IS skip?
 \G a forward reference exists  \G a forward reference exists
 \G so the definition is not skipped!  \G so the definition is not skipped!
     bl word gfind      bl word gfind
     IF dup forward?      IF dup undefined?
         nip          nip
         0=          0=
     ELSE  drop true  THEN ;      ELSE  drop true  THEN ;
Line 1105  NoHeaderFlag off Line 1254  NoHeaderFlag off
     IF  NoHeaderFlag off      IF  NoHeaderFlag off
     ELSE      ELSE
         T align H view,          T align H view,
         tlast @ dup 0> IF  T 1 cells - THEN  A, H  there tlast !          tlast @ dup 0> IF  T 1 cells - H THEN T A, H  there tlast !
         1 headers-named +!      \ Statistic          1 headers-named +!      \ Statistic
         >in @ T name, H >in !          >in @ T name, H >in !
     THEN      THEN
Line 1151  VARIABLE ;Resolve 1 cells allot Line 1300  VARIABLE ;Resolve 1 cells allot
         .sourcepos ." needs doer: " >in @ bl word count type >in ! cr          .sourcepos ." needs doer: " >in @ bl word count type >in ! cr
     THEN      THEN
     ghost tuck swap resolve <do:> swap >magic ! ;      ghost tuck swap resolve <do:> swap >magic ! ;
   
   Variable prim#
   : first-primitive ( n -- )  prim# ! ;
   : Primitive  ( -- ) \ name
       prim# @ T Alias H  -1 prim# +! ;
 >CROSS  >CROSS
   
 \ Conditionals and Comments                            11may93jaw  \ Conditionals and Comments                            11may93jaw
Line 1192  Comment (       Comment \ Line 1346  Comment (       Comment \
   THEN ; immediate    THEN ; immediate
   
 : ghost>cfa  : ghost>cfa
   dup forward? ABORT" CROSS: forward " >link @ ;    dup undefined? ABORT" CROSS: forward " >link @ ;
                                 
 >TARGET  >TARGET
   
Line 1213  Cond: [']  T ' H alit, ;Cond Line 1367  Cond: [']  T ' H alit, ;Cond
 \ modularized                                           14jun97jaw  \ modularized                                           14jun97jaw
   
 : fillcfa   ( usedcells -- )  : fillcfa   ( usedcells -- )
   T cells H xt>body swap - 0 ?DO 0 T c, H LOOP ;    T cells H xt>body swap - 0 ?DO 0 T c, tchar H +LOOP ;
   
 : (>body)   ( cfa -- pfa ) xt>body + ;          ' (>body) T IS >body H  : (>body)   ( cfa -- pfa ) xt>body + ;          ' (>body) T IS >body H
   
Line 1234  Cond: [']  T ' H alit, ;Cond Line 1388  Cond: [']  T ' H alit, ;Cond
   
 : (lit,) ( n -- )   compile lit T  ,  H ;       ' (lit,) IS lit,  : (lit,) ( n -- )   compile lit T  ,  H ;       ' (lit,) IS lit,
   
 : (alit,) ( n -- )  lit, T here cell - H relon ;        ' (alit,) IS alit,  \ if we dont produce relocatable code alit, defaults to lit, jaw
   has? relocate
   [IF]
   : (alit,) ( n -- )  compile lit T  a, H ;       ' (alit,) IS alit,
   [ELSE]
   : (alit,) ( n -- )  lit, ;                      ' (alit,) IS alit,
   [THEN]
   
 : (fini,)         compile ;s ;                ' (fini,) IS fini,  : (fini,)         compile ;s ;                ' (fini,) IS fini,
   
Line 1263  Defer (end-code) Line 1423  Defer (end-code)
     ELSE true ABORT" CROSS: Stack empty" THEN      ELSE true ABORT" CROSS: Stack empty" THEN
     ;      ;
   
 Cond: chars ;Cond  ( Cond ) : chars tchar * ; ( Cond )
   
 >CROSS  >CROSS
   
Line 1420  Cond: DOES> restrict? Line 1580  Cond: DOES> restrict?
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built  \ makes the codefield for a word that is built
   >end @ dup forward? 0=    >end @ dup undefined? 0=
   IF    IF
         dup >magic @ <do:> =          dup >magic @ <do:> =
         IF       doer,           IF       doer, 
Line 1621  Builder Field Line 1781  Builder Field
 : sys?        ( sys -- sys )    dup 0= ?struc ;  : sys?        ( sys -- sys )    dup 0= ?struc ;
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;  : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;
   
 : branchoffset ( src dest -- ) - ;  : branchoffset ( src dest -- ) - tchar / ; \ ?? jaw
   
 : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;  : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;
   
Line 1745  Cond: ENDCASE   restrict? compile drop 0 Line 1905  Cond: ENDCASE   restrict? compile drop 0
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 :noname  :noname \ ?? i think 0 is too much! jaw
     0 compile (do)      0 compile (do)
     branchtomark,  2 to1 ;      branchtomark,  2 to1 ;
   IS do, ( -- target-addr )    IS do, ( -- target-addr )
Line 1786  Cond: S"        restrict? compile (S") Line 1946  Cond: S"        restrict? compile (S")
 Cond: ABORT"    restrict? compile (ABORT") T ," H ;Cond  Cond: ABORT"    restrict? compile (ABORT") T ," H ;Cond
   
 Cond: IS        T ' >body H compile ALiteral compile ! ;Cond  Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
 : IS            T ' >body ! H ;  : IS            T >address ' >body ! H ;
 Cond: TO        T ' >body H compile ALiteral compile ! ;Cond  Cond: TO        T ' >body H compile ALiteral compile ! ;Cond
 : TO            T ' >body ! H ;  : TO            T ' >body ! H ;
   
Line 1917  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 2077  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
   
 also minimal  also minimal
   
 \G doesn't skip line when bit is set in debugmask  : d? d? ;
 : \D name evaluate debugmasksource @ and 0= IF postpone \ THEN ;  
   \G doesn't skip line when debug switch is on
   : \D D? 0= IF postpone \ THEN ;
   
 \G interprets the line if word is not defined  \G interprets the line if word is not defined
 : \- defined? IF postpone \ THEN ;  : \- defined? IF postpone \ THEN ;
Line 1941  previous Line 2103  previous
 \ save-cross                                           17mar93py  \ save-cross                                           17mar93py
   
 >CROSS  >CROSS
 Create magic  s" Gforth10" here over allot swap move  Create magic  s" Gforth2x" here over allot swap move
   
 char 1 bigendian + tcell + magic 7 + c!  bigendian 1+ \ strangely, in magic big=0, little=1
   tcell 1 = 0 and or
   tcell 2 = 2 and or
   tcell 4 = 4 and or
   tcell 8 = 6 and or
   tchar 1 = $00 and or
   tchar 2 = $28 and or
   tchar 4 = $50 and or
   tchar 8 = $78 and or
   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
Line 1972  char 1 bigendian + tcell + magic 7 + c! Line 2143  char 1 bigendian + tcell + magic 7 + c!
   
 : save-region ( addr len -- )  : save-region ( addr len -- )
   bl parse w/o bin create-file throw >r    bl parse w/o bin create-file throw >r
   swap image @ + swap r@ write-file throw    swap >image swap r@ write-file throw
   r> close-file throw ;    r> close-file throw ;
   
 \ words that should be in minimal  \ words that should be in minimal
Line 1984  also minimal Line 2155  also minimal
   
 bigendian Constant bigendian  bigendian Constant bigendian
 : here there ;  : here there ;
   : equ constant ;
   : mark there constant ;
   
 \ compiler directives  \ compiler directives
 : >ram >ram ;  : >ram >ram ;
Line 1993  bigendian Constant bigendian Line 2166  bigendian Constant bigendian
 : tempdp> tempdp> ;  : tempdp> tempdp> ;
 : const constflag on ;  : const constflag on ;
 : warnings name 3 = 0= twarnings ! drop ;  : warnings name 3 = 0= twarnings ! drop ;
 : | NoHeaderFlag on ;  : | ;
   \ : | NoHeaderFlag on ; \ This is broken (damages the last word)
   
 : save-cross save-cross ;  : save-cross save-cross ;
 : save-region save-region ;  : save-region save-region ;
Line 2030  previous Line 2204  previous
   
 : 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  ['] defined2? IS skip? ;
   : skipdef skipdef ;
   
 : \  postpone \ ;  immediate  : \  postpone \ ;  immediate
 : \G T-\G ; immediate  : \G T-\G ; immediate
Line 2076  minimal Line 2251  minimal
 \ these ones are pefered:  \ these ones are pefered:
   
 : lock   turnkey ;  : lock   turnkey ;
 : unlock forth also cross ;  : unlock previous forth also cross ;
   
 : [[ also unlock ;  : [[ also unlock ;
 : ]] previous previous ;  : ]] previous previous ;

Removed from v.1.55  
changed lines
  Added in v.1.75


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