Diff for /gforth/cross.fs between versions 1.53 and 1.69

version 1.53, 1997/09/13 12:04:55 version 1.69, 1999/02/21 11:43:12
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  
   
   
 hex     \ the defualt base for the cross-compiler is hex !!  hex     \ the defualt base for the cross-compiler is hex !!
Line 48  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 59  Warnings off Line 49  Warnings off
     dup c, here swap chars dup allot move ;      dup c, here swap chars dup allot move ;
   
 : SetValue ( n -- <name> )  : SetValue ( n -- <name> )
 \G Same behaviour as "Value" when the <name> is not defined  \G Same behaviour as "Value" if the <name> is not defined
 \G Same behaviour as "to" when <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 order
     ELSE Value THEN ;
   
 : DefaultValue ( n -- <name> )  : DefaultValue ( n -- <name> )
 \G Same behaviour as "Value" when the <name> is not defined  \G Same behaviour as "Value" if the <name> is not defined
 \G SetValue 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 149  stack-warn [IF] Line 144  stack-warn [IF]
 [THEN]  [THEN]
   
   
   
 \ \ GhostNames Ghosts                                  9may93jaw  \ \ GhostNames Ghosts                                  9may93jaw
   
 \ second name source to search trough list  \ second name source to search trough list
Line 234  VARIABLE Already Line 230  VARIABLE Already
   BEGIN @ dup    BEGIN @ dup
   WHILE 2dup cell+ @ =    WHILE 2dup cell+ @ =
   UNTIL nip 2 cells + count    UNTIL nip 2 cells + count
   ELSE  2drop true abort" CROSS: Ghostnames inconsistent"    ELSE  2drop 
           \ true abort" CROSS: Ghostnames inconsistent"
           s" ?!?!?!"
   THEN ;    THEN ;
   
 ' >ghostname ALIAS @name  ' >ghostname ALIAS @name
Line 256  ghost (does>)   ghost noop Line 254  ghost (does>)   ghost noop
 ghost (.")      ghost (S")      ghost (ABORT")  2drop drop  ghost (.")      ghost (S")      ghost (ABORT")  2drop drop
 ghost '                                         drop  ghost '                                         drop
 ghost :docol    ghost :doesjump ghost :dodoes   2drop drop  ghost :docol    ghost :doesjump ghost :dodoes   2drop drop
   ghost :dovar                                    drop
 ghost over      ghost =         ghost drop      2drop drop  ghost over      ghost =         ghost drop      2drop drop
 ghost - drop  ghost - drop
   ghost 2drop drop
   ghost 2dup drop
   
 \ \ Parameter for target systems                         06oct92py  \ \ Parameter for target systems                         06oct92py
   
Line 271  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 286  VARIABLE env-current \ save information Line 287  VARIABLE env-current \ save information
   
 : $has? T environment? H IF ELSE false THEN ;  : $has? T environment? H IF ELSE false THEN ;
   
 >ENVIRON  >ENVIRON get-order get-current swap 1+ set-order
 false SetValue ionly  true SetValue compiler
 true  SetValue cross  true  SetValue cross
 >TARGET  true SetValue standard-threading
   >TARGET previous
   
   
 mach-file count included hex  mach-file count included hex
   
 >ENVIRON  >ENVIRON
   
 s" interpreter" T environment? H 0= ?dup nip [IF] true Value interpreter [THEN]  T has? ec H
 s" ITC" T environment? H 0= ?dup nip [IF] true SetValue ITC [THEN]  [IF]
 s" rom" T environment? H 0= ?dup nip [IF] false Value rom [THEN]  false DefaultValue relocate
   false DefaultValue file
   false DefaultValue OS
   false DefaultValue prims
   false DefaultValue floating
   false DefaultValue glocals
   false DefaultValue dcomps
   false DefaultValue hash
   false DefaultValue xconds
   false DefaultValue header
   [THEN]
   
   true DefaultValue interpreter
   true DefaultValue ITC
   false DefaultValue rom
   
 >TARGET  >TARGET
 s" relocate" T environment? H   s" relocate" T environment? H 
Line 309  s" relocate" T environment? H Line 326  s" relocate" T environment? H
   
 \ \ Create additional parameters                         19jan95py  \ \ Create additional parameters                         19jan95py
   
   1 8 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/byte          Constant tbits/byte
   bits/byte 8 /      Constant tchar
 float              Constant tfloat  float              Constant tfloat
 1 bits/byte lshift Constant maxbyte  1 bits/byte lshift Constant tmaxbyte
 H  H
   
 \ Variables                                            06oct92py  \ Variables                                            06oct92py
Line 354  Variable user-vars 0 user-vars ! Line 375  Variable user-vars 0 user-vars !
   
 >MINIMAL  >MINIMAL
 : makekernel makekernel ;  : makekernel makekernel ;
   >CROSS
   
   : target>bitmask-size ( u1 -- u2 )
     1- tcell>bit rshift 1+ ;
   
   : allocatetarget ( size --- adr )
     dup allocate ABORT" CROSS: No memory for target"
     swap over swap erase ;
   
   
 >CROSS  
   
 \ memregion.fs  \ \ memregion.fs
   
   
 Variable last-defined-region    \ pointer to last defined region  Variable last-defined-region    \ pointer to last defined region
Line 367  Variable mirrored-link          \ linked Line 395  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 380  Variable mirrored-link          \ linked Line 412  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 414  Variable mirrored-link          \ linked Line 447  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 457  T has? rom H Line 491  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 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
Line 469  T has? rom H Line 503  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 ;  
   
 \ switched tdp for rom support                          03jun97jaw    \ 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 ;
   
   \ \ switched tdp for rom support                                03jun97jaw
   
 \ second value is here to store some maximal value for statistics  \ second value is here to store some maximal value for statistics
 \ tempdp is also embedded here but has nothing to do with rom support  \ tempdp is also embedded here but has nothing to do with rom support
Line 507  variable fixed  \ flag: true: no automat Line 560  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 532  variable constflag constflag off Line 589  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 564  bigendian Line 621  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 580  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 670  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 599  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 708  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 615  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 721  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 tchar / 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 \ ." asm: " order
Line 648  previous Line 757  previous
   
 \ \ --------------------        Compiler Plug Ins               01aug97jaw  \ \ --------------------        Compiler Plug Ins               01aug97jaw
   
   \  Compiler States
   
   Variable comp-state
   0 Constant interpreting
   1 Constant compiling
   2 Constant resolving
   3 Constant assembling
   
 Defer lit, ( n -- )  Defer lit, ( n -- )
 Defer alit, ( n -- )  Defer alit, ( n -- )
 Defer branch, ( target-addr -- )  
 Defer ?branch, ( target-addr -- )  Defer branch, ( target-addr -- )        \ compiles a branch
 Defer branchmark, ( -- branch-addr )  Defer ?branch, ( target-addr -- )       \ compiles a ?branch
 Defer ?branchmark, ( -- branch-addr )  Defer branchmark, ( -- branch-addr )    \ reserves room for a branch
 Defer branchto,  Defer ?branchmark, ( -- branch-addr )   \ reserves room for a ?branch
 Defer branchtoresolve, ( branch-addr -- )  Defer ?domark, ( -- branch-addr )       \ reserves room for a ?do branch
 Defer branchfrom, ( -- )  Defer branchto, ( -- )                  \ actual program position is target of a branch (do e.g. alignment)
 Defer branchtomark, ( -- target-addr )  Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
   Defer branchfrom, ( -- )                \ ?!
   Defer branchtomark, ( -- target-addr )  \ marks a branch destination
   
 Defer colon, ( tcfa -- )                \ compiles call to tcfa at current position  Defer colon, ( tcfa -- )                \ compiles call to tcfa at current position
   Defer colonmark, ( -- addr )            \ marks a colon call
 Defer colon-resolve ( tcfa addr -- )  Defer colon-resolve ( tcfa addr -- )
   
 Defer addr-resolve ( target-addr addr -- )  Defer addr-resolve ( target-addr addr -- )
   Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )
   
   Defer do,       ( -- do-token )
   Defer ?do,      ( -- ?do-token )
   Defer for,      ( -- for-token )
   Defer loop,     ( do-token / ?do-token -- )
   Defer +loop,    ( do-token / ?do-token -- )
   Defer next,     ( for-token )
   
 [IFUNDEF] ca>native  [IFUNDEF] ca>native
 defer ca>native   defer ca>native 
Line 671  DEFER >body             \ we need the sy Line 801  DEFER >body             \ we need the sy
                         \ and the target >body                          \ and the target >body
 >CROSS  >CROSS
 T 2 cells H VALUE xt>body  T 2 cells H VALUE xt>body
 DEFER doprim,  DEFER doprim,   \ compiles start of a primitive
 DEFER docol,     \ compiles start of definition and doer  DEFER docol,    \ compiles start of a colon definition
 DEFER doer,               DEFER doer,             
 DEFER fini,      \ compiles end of definition ;s  DEFER fini,      \ compiles end of definition ;s
 DEFER doeshandler,  DEFER doeshandler,
Line 681  DEFER dodoes, Line 811  DEFER dodoes,
 DEFER ]comp     \ starts compilation  DEFER ]comp     \ starts compilation
 DEFER comp[     \ ends compilation  DEFER comp[     \ ends compilation
   
 : (cc) T a, H ;                 ' (cc) IS colon,  : (cc) T a, H ;                                 ' (cc) IS colon,
 : (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve  
 : (ar) T ! H ;                  ' (ar) IS addr-resolve  : (cr) >tempdp ]comp colon, comp[ tempdp> ;     ' (cr) IS colon-resolve
   : (ar) T ! H ;                                  ' (ar) IS addr-resolve
   : (dr)  ( ghost res-pnt target-addr addr )
           >tempdp drop over 
           dup >magic @ <do:> =
           IF      doer,
           ELSE    dodoes,
           THEN 
           tempdp> ;                               ' (dr) IS doer-resolve
   
   : (cm) ( -- addr )
       T here align H
       -1 colon, ;                                 ' (cm) IS colonmark,
   
 >TARGET  >TARGET
 : compile, colon, ;  : compile, colon, ;
Line 691  DEFER comp[     \ ends compilation Line 833  DEFER comp[     \ ends compilation
   
 \ file loading  \ file loading
   
   : >fl-id   1 cells + ;
   : >fl-name 2 cells + ;
   
 Variable filelist 0 filelist !  Variable filelist 0 filelist !
 0 Value  loadfile  Create NoFile ," #load-file#"
   0 Value  filemem
   : loadfile  FileMem ?dup IF >fl-name ELSE NoFile THEN ;
   
 0 [IF] \ !! JAW WIP  1 [IF] \ !! JAW WIP
   
 : add-included-file ( adr len -- )  : add-included-file ( adr len -- )
         dup 2 cells + allocate throw >r          dup char+ >fl-name allocate throw >r
         r@ 1 cells + dup TO loadfile place          r@ >fl-name place
         filelist @ r@ !          filelist @ r@ !
         r> filelist ! ;          r> dup filelist ! to FileMem
           ;
   
 : included? ( c-addr u -- f )  : included? ( c-addr u -- f )
         filelist          filelist
Line 712  Variable filelist 0 filelist ! Line 860  Variable filelist 0 filelist !
         2drop drop false ;                2drop drop false ;      
   
 : included   : included 
         cr ." Including: " 2dup type ." ..."  \       cr ." Including: " 2dup type ." ..."
         2dup add-included-file included ;          FileMem >r
           2dup add-included-file included 
           r> to FileMem ;
   
 : include bl word count included ;  : include bl word count included ;
   
Line 724  Variable filelist 0 filelist ! Line 874  Variable filelist 0 filelist !
 \ resolve structure  \ resolve structure
   
 : >next ;               \ link to next field  : >next ;               \ link to next field
 : >tag cell+ ;          \ indecates type of reference: 0: call, 1: address  : >tag cell+ ;          \ indecates type of reference: 0: call, 1: address, 2: doer
 : >taddr cell+ cell+ ;    : >taddr cell+ cell+ ;  
 : >ghost 3 cells + ;  : >ghost 3 cells + ;
 : >file 4 cells + ;  : >file 4 cells + ;
 : >line 5 cells + ;  : >line 5 cells + ;
   
   : (refered) ( ghost addr tag -- )
   \G creates a reference to ghost at address taddr
       rot >r here r@ >link @ , r> >link ! 
       ( taddr tag ) ,
       ( taddr ) , 
       last-header-ghost @ , 
       loadfile , 
       sourceline# , 
     ;
   
 : refered ( ghost tag -- )  : refered ( ghost tag -- )
 \G creates a resolve structure  \G creates a resolve structure
   swap >r here r@ >link @ , r@ >link ! ( tag ) ,      T here aligned H swap (refered)
   T here aligned H , r> drop  last-header-ghost @ ,     ;
   loadfile , sourceline# ,   
   : killref ( addr ghost -- )
   \G kills a forward reference to ghost at position addr
   \G this is used to eleminate a :dovar refence after making a DOES>
       dup >magic @ <fwd> <> IF 2drop EXIT THEN
       swap >r >link
       BEGIN dup @ dup  ( addr last this )
       WHILE dup >taddr @ r@ =
            IF   @ over !
            ELSE nip THEN
       REPEAT rdrop 2drop 
   ;    ;
   
 Defer resolve-warning  Defer resolve-warning
Line 750  Defer resolve-warning Line 920  Defer resolve-warning
     
 \ resolve                                              14oct92py  \ resolve                                              14oct92py
   
  : resolve-loop ( ghost tcfa -- ghost tcfa )   : resolve-loop ( ghost resolve-list tcfa -- )
   >r dup >link      >r
   BEGIN @ dup WHILE       BEGIN dup WHILE 
         resolve-warning   \         dup >tag @ 2 = IF reswarn-forward THEN
         r@ over >taddr @             resolve-warning 
         2 pick >tag @            r@ over >taddr @ 
         IF      addr-resolve            2 pick >tag @
         ELSE    colon-resolve            CASE  0 OF colon-resolve ENDOF
         THEN                  1 OF addr-resolve ENDOF
   REPEAT drop r> ;                  2 OF doer-resolve ENDOF
             ENDCASE
             @ \ next list element
       REPEAT 2drop rdrop 
     ;
   
 \ : resolve-loop ( ghost tcfa -- ghost tcfa )  \ : resolve-loop ( ghost tcfa -- ghost tcfa )
 \  >r dup >link @  \  >r dup >link @
Line 786  Exists-Warnings on Line 960  Exists-Warnings on
   THEN ;    THEN ;
   
 : resolve  ( ghost tcfa -- )  : resolve  ( ghost tcfa -- )
 \ resolve referencies to ghost with tcfa  \G resolve referencies to ghost with tcfa
   over forward? 0= IF  exists EXIT THEN      \ is ghost resolved?, second resolve means another definition with the
   resolve-loop  over >link ! <res> swap >magic !       \ same name
   ['] noop IS resolve-warning       over forward? 0= IF  exists EXIT THEN
       \ get linked-list
       swap >r r@ >link @ swap \ ( list tcfa R: ghost )
       \ mark ghost as resolved
       dup r@ >link ! <res> r@ >magic !
       \ loop through forward referencies
       r> -rot 
       comp-state @ >r Resolving comp-state !
       resolve-loop 
       r> comp-state !
   
       ['] noop IS resolve-warning 
   ;    ;
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
 : is-forward   ( ghost -- )  : is-forward   ( ghost -- )
 \  >link dup @ there rot !  T  A,  H ;    colonmark, 0 (refered) ; \ compile space for call
   0 refered  -1 colon, ;  
   
 : is-resolved   ( ghost -- )  : is-resolved   ( ghost -- )
   >link @ colon, ; \ compile-call    >link @ colon, ; \ compile-call
Line 870  VARIABLE ^imm Line 1054  VARIABLE ^imm
                 <imm> ^imm @ ! ;                  <imm> ^imm @ ! ;
 : restrict      20 flag! ;  : restrict      20 flag! ;
   
 : isdoer        <do:> last-header-ghost @ >magic ! ;  : isdoer        
   \G define a forth word as doer, this makes obviously only sence on
   \G forth processors such as the PSC1000
                   <do:> last-header-ghost @ >magic ! ;
 >CROSS  >CROSS
   
 \ ALIAS2 ansforth conform alias                          9may93jaw  \ ALIAS2 ansforth conform alias                          9may93jaw
Line 890  VARIABLE ^imm Line 1077  VARIABLE ^imm
   
 \ Target Document Creation (goes to crossdoc.fd)       05jul95py  \ Target Document Creation (goes to crossdoc.fd)       05jul95py
   
 s" doc/crossdoc.fd" r/w create-file throw value doc-file-id  s" ./doc/crossdoc.fd" r/w create-file throw value doc-file-id
 \ contains the file-id of the documentation file  \ contains the file-id of the documentation file
   
 : T-\G ( -- )  : T-\G ( -- )
Line 975  Defer skip? ' false IS skip? Line 1162  Defer skip? ' false IS skip?
   
 \ Target header creation  \ Target header creation
   
   Variable CreateFlag
   CreateFlag off
   
 VARIABLE CreateFlag CreateFlag off  Variable NoHeaderFlag
   NoHeaderFlag off
   
 : 0.r ( n1 n2 -- ) 0 swap <# 0 ?DO # LOOP #> type ;  : 0.r ( n1 n2 -- ) 
       base @ >r hex 
       0 swap <# 0 ?DO # LOOP #> type 
       r> base ! ;
 : .sym  : .sym
   bounds     bounds 
   DO I c@ dup    DO I c@ dup
Line 986  VARIABLE CreateFlag CreateFlag off Line 1179  VARIABLE CreateFlag CreateFlag off
                 '\ OF drop ." \\" ENDOF                  '\ OF drop ." \\" ENDOF
                 dup OF emit ENDOF                  dup OF emit ENDOF
         ENDCASE          ENDCASE
   LOOP ;      LOOP ;
   
 : (Theader ( "name" -- ghost )  : (Theader ( "name" -- ghost )
 \  >in @ bl word count type 2 spaces >in !      \  >in @ bl word count type 2 spaces >in !
 \ wordheaders will always be compiled to rom      \ wordheaders will always be compiled to rom
   switchrom      switchrom
   T align H view,      \ build header in target
   tlast @ dup 0> IF  T 1 cells - THEN  A, H  there tlast !      NoHeaderFlag @
   1 headers-named +!    \ Statistic      IF  NoHeaderFlag off
   >in @ T name, H >in ! T here H tlastcfa !      ELSE
   \ Symbol table          T align H view,
   \ >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !          tlast @ dup 0> IF  T 1 cells - H THEN T A, H  there tlast !
   CreateFlag @ IF          1 headers-named +!      \ Statistic
        >in @ alias2 swap >in !         \ create alias in target          >in @ T name, H >in !
        >in @ ghost swap >in !      THEN
        swap also ghosts ' previous swap !     \ tick ghost and store in alias      T cfalign here H tlastcfa !
        CreateFlag off      \ Symbol table
   ELSE ghost THEN  \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !
   dup Last-Header-Ghost !      CreateFlag @
   dup >magic ^imm !     \ a pointer for immediate      IF
   Already @ IF  dup >end tdoes !          >in @ alias2 swap >in !         \ create alias in target
   ELSE 0 tdoes ! THEN          >in @ ghost swap >in !
   80 flag!          swap also ghosts ' previous swap !     \ tick ghost and store in alias
   cross-doc-entry cross-tag-entry ;          CreateFlag off
       ELSE ghost
       THEN
       dup Last-Header-Ghost !
       dup >magic ^imm !     \ a pointer for immediate
       Already @
       IF  dup >end tdoes !
       ELSE 0 tdoes !
       THEN
       80 flag!
       cross-doc-entry cross-tag-entry ;
   
 VARIABLE ;Resolve 1 cells allot  VARIABLE ;Resolve 1 cells allot
 \ this is the resolver information from ":"  \ this is the resolver information from ":"
Line 1033  VARIABLE ;Resolve 1 cells allot Line 1236  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 1095  Cond: [']  T ' H alit, ;Cond Line 1303  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 1116  Cond: [']  T ' H alit, ;Cond Line 1324  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 1145  Defer (end-code) Line 1359  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 1210  Cond: MAXI Line 1424  Cond: MAXI
 \ ]                                                     9may93py/jaw  \ ]                                                     9may93py/jaw
   
 : ] state on  : ] state on
       Compiling comp-state !
     BEGIN      BEGIN
         BEGIN >in @ bl word          BEGIN >in @ bl word
               dup c@ 0= WHILE 2drop refill 0=                dup c@ 0= WHILE 2drop refill 0=
Line 1254  Cond: ; ( -- ) restrict? Line 1469  Cond: ; ( -- ) restrict?
                state off                 state off
                ;Resolve @                 ;Resolve @
                IF ;Resolve @ ;Resolve cell+ @ resolve THEN                 IF ;Resolve @ ;Resolve cell+ @ resolve THEN
                   Interpreting comp-state !
                ;Cond                 ;Cond
 Cond: [  restrict? state off ;Cond  Cond: [  restrict? state off Interpreting comp-state ! ;Cond
   
 >CROSS  >CROSS
   
   Create GhostDummy ghostheader
   <res> GhostDummy >magic !
   
 : !does ( does-action -- )  : !does ( does-action -- )
 \ !! zusammenziehen und dodoes, machen!  \ !! zusammenziehen und dodoes, machen!
     tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;      tlastcfa @ [G'] :dovar killref
   \    tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
 \ !! geht so nicht, da dodoes, ghost will!  \ !! geht so nicht, da dodoes, ghost will!
 \     tlastcfa @ >tempdp dodoes, tempdp> ;      GhostDummy >link ! GhostDummy 
       tlastcfa @ >tempdp dodoes, tempdp> ;
   
 >TARGET  >TARGET
 Cond: DOES> restrict?  Cond: DOES> restrict?
Line 1284  Cond: DOES> restrict? Line 1506  Cond: DOES> restrict?
 \ for do:-xt an additional entry after the normal ghost-enrys is used  \ for do:-xt an additional entry after the normal ghost-enrys is used
   
   >in @ alias2 swap dup >in ! >r >r    >in @ alias2 swap dup >in ! >r >r
   Make-Ghost rot swap >exec ! ,    Make-Ghost 
     rot swap >exec dup @ ['] NoExec <>
     IF 2drop ELSE ! THEN
     ,
   r> r> >in !    r> r> >in !
   also ghosts ' previous swap ! ;    also ghosts ' previous swap ! ;
 \  DOES>  dup >exec @ execute ;  \  DOES>  dup >exec @ execute ;
Line 1294  Cond: DOES> restrict? Line 1519  Cond: DOES> restrict?
   >end @ dup forward? 0=    >end @ dup forward? 0=
   IF    IF
         dup >magic @ <do:> =          dup >magic @ <do:> =
         IF  doer, EXIT THEN          IF       doer, 
           ELSE    dodoes,
           THEN
           EXIT
   THEN    THEN
 \  compile :dodoes gexecute  \  compile :dodoes gexecute
 \  T here H tcell - reloff   \  T here H tcell - reloff 
   dodoes,    2 refered 
 ;    0 fillcfa
     ;
   
 : TCreate ( <name> -- )  : TCreate ( <name> -- )
   executed-ghost @    executed-ghost @
Line 1384  by: :dovar ( ghost -- addr ) ;DO Line 1613  by: :dovar ( ghost -- addr ) ;DO
 Builder Create  Builder Create
   
 T has? rom H [IF]  T has? rom H [IF]
 Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;  Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
 by (Constant)  by (Constant)
 Builder Variable  Builder Variable
 [ELSE]  [ELSE]
Line 1394  Builder Variable Line 1623  Builder Variable
 [THEN]  [THEN]
   
 T has? rom H [IF]  T has? rom H [IF]
 Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;  Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;
   by (Constant)
   Builder 2Variable
   [ELSE]
   Build: T 0 , 0 , H ;
   by Create
   Builder 2Variable
   [THEN]
   
   T has? rom H [IF]
   Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
 by (Constant)  by (Constant)
 Builder AVariable  Builder AVariable
 [ELSE]  [ELSE]
Line 1471  Builder Field Line 1710  Builder Field
 \ ' 2Constant Alias2 end-struct  \ ' 2Constant Alias2 end-struct
 \ 0 1 T Chars H 2Constant struct  \ 0 1 T Chars H 2Constant struct
   
 0 [IF]  
   
 \ structural conditionals                              17dec92py  
   
 >CROSS  
 : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;  
 : sys?        ( sys -- sys )    dup 0= ?struc ;  
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;  
   
 : branchoffset ( src dest -- ) - ;  
 : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;  
 : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;  
 >TARGET  
   
 \ Structural Conditionals                              12dec92py  
   
 Cond: BUT       restrict? sys? swap ;Cond  
 Cond: YET       restrict? sys? dup ;Cond  
   
 >CROSS  
 Variable tleavings  
 >TARGET  
   
 Cond: DONE   ( addr -- )  restrict? tleavings @  
       BEGIN  2dup u> 0=  WHILE  dup T @ H swap >resolve REPEAT  
       tleavings ! drop ;Cond  
   
 >CROSS  
 : (leave  T here H tleavings @ T , H  tleavings ! ;  
 >TARGET  
   
 Cond: LEAVE     restrict? compile branch (leave ;Cond  
 Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave  ;Cond  
   
 \ Structural Conditionals                              12dec92py  
   
 Cond: AHEAD     restrict? compile branch >mark ;Cond  
 Cond: IF        restrict? compile ?branch >mark ;Cond  
 Cond: THEN      restrict? sys? branchto, dup T @ H ?struc >resolve ;Cond  
 Cond: ELSE      restrict? sys? compile AHEAD swap compile THEN ;Cond  
   
 Cond: BEGIN     restrict? T branchto, here ( dup ." B" hex. ) H ;Cond  
 Cond: WHILE     restrict? sys? compile IF swap ;Cond  
 Cond: AGAIN     restrict? sys? compile branch <resolve ;Cond  
 Cond: UNTIL     restrict? sys? compile ?branch <resolve ;Cond  
 Cond: REPEAT    restrict? over 0= ?struc compile AGAIN compile THEN ;Cond  
   
 Cond: CASE      restrict? 0 ;Cond  
 Cond: OF        restrict? 1+ >r compile over compile =  
                 compile IF compile drop r> ;Cond  
 Cond: ENDOF     restrict? >r compile ELSE r> ;Cond  
 Cond: ENDCASE   restrict? compile drop 0 ?DO  compile THEN  LOOP ;Cond  
   
 \ Structural Conditionals                              12dec92py  
   
 Cond: DO        restrict? compile (do)   T here H ;Cond  
 Cond: ?DO       restrict? compile (?do)  T (leave here H ;Cond  
 Cond: FOR       restrict? compile (for)  T here H ;Cond  
   
 >CROSS  
 : loop]   dup <resolve tcell - compile DONE compile unloop ;  
 >TARGET  
   
 Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond  
 Cond: +LOOP     restrict? sys? compile (+loop) loop] ;Cond  
 Cond: NEXT      restrict? sys? compile (next)  loop] ;Cond  
   
 [ELSE]  
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py
   
 >CROSS  >CROSS
Line 1547  Cond: NEXT      restrict? sys? compile ( Line 1717  Cond: NEXT      restrict? sys? compile (
 : 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 ;
   
 : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;  : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;
   
 :noname compile branch T here branchoffset , H ; IS branch,  :noname compile branch T here branchoffset , H ;
 :noname compile ?branch T here branchoffset , H ; IS ?branch,    IS branch, ( target-addr -- )
 :noname compile branch T here 0 , H ; IS branchmark,  :noname compile ?branch T here branchoffset , H ;
 :noname compile ?branch T here 0 , H ; IS  ?branchmark,    IS ?branch, ( target-addr -- )
 :noname dup T @ H ?struc T here over branchoffset swap ! H ; IS branchtoresolve,  :noname compile branch T here 0 , H ;
 :noname branchto, T here H ; IS branchtomark,    IS branchmark, ( -- branchtoken )
   :noname compile ?branch T here 0 , H ;
     IS ?branchmark, ( -- branchtoken )
   :noname T here 0 , H ;
     IS ?domark, ( -- branchtoken )
   :noname dup T @ H ?struc T here over branchoffset swap ! H ;
     IS branchtoresolve, ( branchtoken -- )
   :noname branchto, T here H ;
     IS branchtomark, ( -- target-addr )
   
 >TARGET  >TARGET
   
Line 1567  Cond: NEXT      restrict? sys? compile ( Line 1745  Cond: NEXT      restrict? sys? compile (
 Cond: BUT       restrict? sys? swap ;Cond  Cond: BUT       restrict? sys? swap ;Cond
 Cond: YET       restrict? sys? dup ;Cond  Cond: YET       restrict? sys? dup ;Cond
   
 1 [IF]  0 [IF]
 >CROSS  >CROSS
 Variable tleavings  Variable tleavings
 >TARGET  >TARGET
Line 1577  Cond: DONE   ( addr -- )  restrict? tlea Line 1755  Cond: DONE   ( addr -- )  restrict? tlea
       tleavings ! drop ;Cond        tleavings ! drop ;Cond
   
 >CROSS  >CROSS
 : (leave  T here H tleavings @ T , H  tleavings ! ;  : (leave)  T here H tleavings @ T , H  tleavings ! ;
 >TARGET  >TARGET
   
 Cond: LEAVE     restrict? compile branch (leave ;Cond  Cond: LEAVE     restrict? compile branch (leave) ;Cond
 Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave  ;Cond  Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave)  ;Cond
   
 [ELSE]  [ELSE]
     \ !! This is WIP      \ !! This is WIP
Line 1590  Cond: ?LEAVE    restrict? compile 0=  co Line 1768  Cond: ?LEAVE    restrict? compile 0=  co
           
 >CROSS  >CROSS
 Variable tleavings 0 tleavings !  Variable tleavings 0 tleavings !
   : (done) ( addr -- )
       tleavings @
       BEGIN  dup
       WHILE
           >r dup r@ cell+ @ \ address of branch
           u> 0=      \ lower than DO?     
       WHILE
           r@ 2 cells + @ \ branch token
           branchtoresolve,
           r@ @ r> free throw
       REPEAT  r>  THEN
       tleavings ! drop ;
   
 >TARGET  >TARGET
   
 Cond: DONE   ( addr -- )    Cond: DONE   ( addr -- )  restrict? (done) ;Cond
       restrict? tleavings @  
       BEGIN  dup  
       WHILE  >r dup r@ cell+ @ \ address of branch  
              u> 0=         \ lower than DO?       
       WHILE  r@ 2 cells + @ \ branch token  
              branchtoresolve,  
              r@ @ r> free throw  
       REPEAT drop r>  
       THEN  
       tleavings ! drop ;Cond  
   
 >CROSS  >CROSS
 : (leave ( branchtoken -- )  : (leave) ( branchtoken -- )
     3 cells allocate throw >r      3 cells allocate throw >r
     T here H r@ cell+ !      T here H r@ cell+ !
     r@ 2 cells + !      r@ 2 cells + !
Line 1613  Cond: DONE   ( addr -- ) Line 1794  Cond: DONE   ( addr -- )
     r> tleavings ! ;      r> tleavings ! ;
 >TARGET  >TARGET
   
 Cond: LEAVE     restrict? branchmark, (leave ;Cond  Cond: LEAVE     restrict? branchmark, (leave) ;Cond
 Cond: ?LEAVE    restrict? compile 0=  ?branchmark, (leave  ;Cond  Cond: ?LEAVE    restrict? compile 0=  ?branchmark, (leave)  ;Cond
   
 [THEN]  [THEN]
   
   >CROSS
   \ !!JW ToDo : Move to general tools section
   
   : to1 ( x1 x2 xn n -- addr )
   \G packs n stack elements in a allocated memory region
      dup dup 1+ cells allocate throw dup >r swap 1+
      0 DO tuck ! cell+ LOOP
      drop r> ;
   : 1to ( addr -- x1 x2 xn )
   \G unpacks the elements saved by to1
       dup @ swap over cells + swap
       0 DO  dup @ swap 1 cells -  LOOP
       free throw ;
   
   : loop]     branchto, dup <resolve tcell - (done) ;
   
   : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
   
   >TARGET
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 >TARGET  >TARGET
Line 1640  Cond: ENDCASE   restrict? compile drop 0 Line 1841  Cond: ENDCASE   restrict? compile drop 0
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 Cond: DO        restrict? compile (do)   T here H ;Cond  :noname \ ?? i think 0 is too much! jaw
 Cond: ?DO       restrict? compile (?do)  T (leave here H ;Cond      0 compile (do)
 Cond: FOR       restrict? compile (for)  T here H ;Cond      branchtomark,  2 to1 ;
     IS do, ( -- target-addr )
 >CROSS  
 : loop]   branchto, dup <resolve tcell - compile DONE compile unloop ;  \ :noname
 >TARGET  \     compile 2dup compile = compile IF
   \     compile 2drop compile ELSE
 Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond  \     compile (do) branchtomark, 2 to1 ;
 Cond: +LOOP     restrict? sys? compile (+loop) loop] ;Cond  \   IS ?do,
 Cond: NEXT      restrict? sys? compile (next)  loop] ;Cond      
   :noname
 [THEN]      0 compile (?do)  ?domark, (leave)
       branchtomark,  2 to1 ;
     IS ?do, ( -- target-addr )
   :noname compile (for) branchtomark, ;
     IS for, ( -- target-addr )
   :noname 1to compile (loop)  loop] compile unloop skiploop] ;
     IS loop, ( target-addr -- )
   :noname 1to compile (+loop)  loop] compile unloop skiploop] ;
     IS +loop, ( target-addr -- )
   :noname compile (next)  loop] compile unloop ;
     IS next, ( target-addr -- )
   
   Cond: DO        restrict? do, ;Cond
   Cond: ?DO       restrict? ?do, ;Cond
   Cond: FOR       restrict? for, ;Cond
   
   Cond: LOOP      restrict? sys? loop, ;Cond
   Cond: +LOOP     restrict? sys? +loop, ;Cond
   Cond: NEXT      restrict? sys? next, ;Cond
   
 \ String words                                         23feb93py  \ String words                                         23feb93py
   
Line 1663  Cond: S"        restrict? compile (S") Line 1882  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 1694  Cond: compile ( -- ) restrict? \ name Line 1913  Cond: compile ( -- ) restrict? \ name
       0> IF    gexecute        0> IF    gexecute
          ELSE  dup >magic @ <imm> =           ELSE  dup >magic @ <imm> =
                IF   gexecute                 IF   gexecute
                ELSE compile (compile) gexecute THEN THEN ;Cond                 ELSE compile (compile) addr, THEN THEN ;Cond
   
 Cond: postpone ( -- ) restrict? \ name  Cond: postpone ( -- ) restrict? \ name
       bl word gfind dup 0= ABORT" CROSS: Can't compile"        bl word gfind dup 0= ABORT" CROSS: Can't compile"
       0> IF    gexecute        0> IF    gexecute
          ELSE  dup >magic @ <imm> =           ELSE  dup >magic @ <imm> =
                IF   gexecute                 IF   gexecute
                ELSE compile (compile) gexecute THEN THEN ;Cond                 ELSE compile (compile) addr, THEN THEN ;Cond
              
   \ \ minimal definitions
              
 >MINIMAL  >MINIMAL
 also minimal  also minimal
 \ Usefull words                                        13feb93py  \ Usefull words                                        13feb93py
   
 : KB  400 * ;  : KB  400 * ;
   
   \ \ [IF] [ELSE] [THEN] ...                              14sep97jaw
   
   \ it is useful to define our own structures and not to rely
   \ on the words in the compiler
   \ The words in the compiler might be defined with vocabularies
   \ this doesn't work with our self-made compile-loop
   
   Create parsed 20 chars allot    \ store word we parsed
   
   : upcase
       parsed count bounds
       ?DO I c@ toupper I c! LOOP ;
   
   : [ELSE]
       1 BEGIN
           BEGIN bl word count dup WHILE
               comment? parsed place upcase parsed count
               2dup s" [IF]" compare 0= >r 
               2dup s" [IFUNDEF]" compare 0= >r
               2dup s" [IFDEF]" compare 0= r> or r> or
               IF   2drop 1+
               ELSE 2dup s" [ELSE]" compare 0=
                   IF   2drop 1- dup
                       IF 1+
                       THEN
                   ELSE
                       2dup s" [ENDIF]" compare 0= >r
                       s" [THEN]" compare 0= r> or
                       IF 1- THEN
                   THEN
               THEN
               ?dup 0= ?EXIT
           REPEAT
           2drop refill 0=
       UNTIL drop ; immediate
     
   : [THEN] ( -- ) ; immediate
   
   : [ENDIF] ( -- ) ; immediate
   
   : [IF] ( flag -- )
       0= IF postpone [ELSE] THEN ; immediate 
   
   Cond: [IF]      postpone [IF] ;Cond
   Cond: [THEN]    postpone [THEN] ;Cond
   Cond: [ELSE]    postpone [ELSE] ;Cond
   
 \ define new [IFDEF] and [IFUNDEF]                      20may93jaw  \ define new [IFDEF] and [IFUNDEF]                      20may93jaw
   
 : defined? defined? ;  : defined? defined? ;
Line 1727  also minimal Line 1995  also minimal
   
 : [IFUNDEF] defined? 0= postpone [IF] ;  : [IFUNDEF] defined? 0= postpone [IF] ;
   
   Cond: [IFDEF]   postpone [IFDEF] ;Cond
   
   Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
   
 \ C: \- \+ Conditional Compiling                         09jun93jaw  \ C: \- \+ Conditional Compiling                         09jun93jaw
   
 : C: >in @ defined? 0=  : C: >in @ defined? 0=
Line 1760  Cond: \D \D ;Cond Line 2032  Cond: \D \D ;Cond
 \G defines ghost for words that we want to be compiled  \G defines ghost for words that we want to be compiled
   BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;    BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;
   
 : [IF]   postpone [IF] ;  
 : [THEN] postpone [THEN] ;  
 : [ELSE] postpone [ELSE] ;  
   
 Cond: [IF]      [IF] ;Cond  
 Cond: [IFDEF]   [IFDEF] ;Cond  
 Cond: [IFUNDEF] [IFUNDEF] ;Cond  
 Cond: [THEN]    [THEN] ;Cond  
 Cond: [ELSE]    [ELSE] ;Cond  
   
 previous  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 1806  char 1 bigendian + tcell + magic 7 + c! Line 2077  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 1818  also minimal Line 2089  also minimal
   
 bigendian Constant bigendian  bigendian Constant bigendian
 : here there ;  : here there ;
   : equ constant ;
   : mark there constant ;
   
   \ compiler directives
 : >ram >ram ;  : >ram >ram ;
 : >rom >rom ;  : >rom >rom ;
 : >auto >auto ;  : >auto >auto ;
Line 1825  bigendian Constant bigendian Line 2100  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 ; \ 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.53  
changed lines
  Added in v.1.69


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