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

version 1.61, 1998/12/22 13:41:18 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,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 67  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
     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 128  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 153  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 181  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 250  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 282  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 325  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 336  s" relocate" T environment? H Line 370  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 361  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 396  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 409  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 443  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 486  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 498  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 536  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 561  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 575  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 608  bigendian Line 686  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 617  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 636  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 Sc@ ;  : c@ ( taddr -- char )  >image Sc@ ;
Line 653  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 772  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, tchar H +LOOP ;      T here H cfalign+ 0 ?DO  bl T c, tchar H +LOOP ;
   
 : >address              dup 0>= IF tchar / THEN ;  : >address              dup 0>= IF tbyte / THEN ; \ ?? jaw 
 : A!                    swap >address swap dup relon T ! H ;  : A!                    swap >address swap dup relon T ! H ;
 : A,    ( w -- )        >address T here H relon T , H ;  : A,    ( w -- )        >address T here H relon T , H ;
   
Line 669  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 788  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
   
 : X     also target bl word find  : X     also target bl word find
         IF      state @ IF compile,          IF      state @ IF compile,
Line 766  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 787  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 891  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 1068  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 1077  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 1164  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 1205  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 1247  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 1433  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 1634  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 -- ) - tchar / ;  : 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 1758  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 1799  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 1930  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 1954  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 1985  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 1997  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 2044  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 2090  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.61  
changed lines
  Added in v.1.75


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