Diff for /gforth/cross.fs between versions 1.58 and 1.73

version 1.58, 1998/12/08 22:02:38 version 1.73, 1999/05/05 12:07:55
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,1996,1997,1998 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 ['] to execute 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 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
Line 281  VARIABLE env-current \ save information Line 272  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                  \ !! JAW abort is just for testing
Line 302  true  SetValue cross Line 293  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 315  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 327  s" relocate" T environment? H
   
 \ \ Create additional parameters                         19jan95py  \ \ Create additional parameters                         19jan95py
   
 1 8 lshift Constant maxbyte  \ 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
 bits/byte 8 /      Constant tchar  bits/char H bits/byte T /      
 float              Constant tfloat                          Constant tchar
 1 bits/byte lshift Constant tmaxbyte  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 359  Variable bit$ Line 378  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  
   
 : makekernel ( targetsize -- targetsize )  
   bit$  over 1- tcell>bit rshift 1+ initmem  
   image over initmem ;  
   
 >MINIMAL  
 : makekernel makekernel ;  
   
   : allocatetarget ( size --- adr )
 >CROSS    dup allocate ABORT" CROSS: No memory for target"
     swap over swap erase ;
   
 \ \ memregion.fs  \ \ memregion.fs
   
Line 394  Variable mirrored-link          \ linked Line 394  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 407  Variable mirrored-link          \ linked Line 411  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 441  Variable mirrored-link          \ linked Line 446  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 484  T has? rom H Line 490  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 496  T has? rom H Line 502  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 534  variable fixed  \ flag: true: no automat Line 567  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 559  variable constflag constflag off Line 596  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 573  variable constflag constflag off Line 610  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 606  bigendian Line 643  bigendian
      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 ;
 [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 615  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 677  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 634  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 715  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 Sc@ ;  : c@ ( taddr -- char )  >image Sc@ ;
Line 651  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 729  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 : 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    tchar 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
   
Line 666  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 745  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
   ?DO  dup T c@ H I T c! H 1+    ?DO  dup T c@ H I T c! H 1+
   tchar +LOOP  drop ;    tchar +LOOP  drop ;
   
   \ \ Load Assembler
   
 >TARGET  >TARGET
 H also Forth definitions \ ." asm: " order  H also Forth definitions \ ." asm: " order
   
Line 763  DEFER comp[     \ ends compilation Line 844  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 1115  NoHeaderFlag off Line 1197  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 1161  VARIABLE ;Resolve 1 cells allot Line 1243  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 1223  Cond: [']  T ' H alit, ;Cond Line 1310  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 1244  Cond: [']  T ' H alit, ;Cond Line 1331  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 1631  Builder Field Line 1724  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 1755  Cond: ENDCASE   restrict? compile drop 0 Line 1848  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 1796  Cond: S"        restrict? compile (S") Line 1889  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 1951  previous Line 2044  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 1982  char 1 bigendian + tcell + magic 7 + c! Line 2084  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 1994  also minimal Line 2096  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 2003  bigendian Constant bigendian Line 2107  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 ;

Removed from v.1.58  
changed lines
  Added in v.1.73


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