Diff for /gforth/cross.fs between versions 1.52 and 1.67

version 1.52, 1997/08/31 19:31:28 version 1.67, 1999/02/19 18:25:28
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 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 ['] to execute 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 128  false DefaultValue create-forward-warn Line 118  false DefaultValue create-forward-warn
   
 previous >CROSS  previous >CROSS
   
   : .dec
     base @ decimal swap . base ! ;
   
 : .sourcepos  : .sourcepos
   cr sourcefilename type ." :"    cr sourcefilename type ." :"
   base @ decimal sourceline# . base ! ;    sourceline# .dec ;
   
 : warnhead  : warnhead
 \G display error-message head  \G display error-message head
Line 146  stack-warn [IF] Line 139  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 231  VARIABLE Already Line 225  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 253  ghost (does>)   ghost noop Line 249  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 268  VARIABLE env-current \ save information Line 267  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 IF ELSE false THEN ;  : has?  bl word count T environment? H 
           IF      \ environment variable is present, return its value
           ELSE    \ environment variable is not present, return false
                   \ !! JAW abort is just for testing
                   false true ABORT" arg" 
           THEN ;
   
 : $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
 true Value cross  true SetValue compiler
 >TARGET  true  SetValue cross
   true SetValue standard-threading
   >TARGET previous
   
   
 mach-file count included hex  mach-file count included hex
   
 >TARGET  >ENVIRON
   
   T has? ec H
   [IF]
   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]
   
 [IFUNDEF] has-interpreter true Value has-interpreter [THEN]  true DefaultValue interpreter
 [IFUNDEF] itc true Value itc [THEN]  true DefaultValue ITC
 [IFUNDEF] has-rom false Value has-rom [THEN]  false DefaultValue rom
   
   >TARGET
   s" relocate" T environment? H 
   [IF]    SetValue NIL
   [ELSE]  >ENVIRON T NIL H SetValue relocate
   [THEN]
   
 >CROSS  >CROSS
   
 \ \ 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 339  Variable user-vars 0 user-vars ! Line 370  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 352  Variable mirrored-link          \ linked Line 390  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 365  Variable mirrored-link          \ linked Line 407  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 @ , ;    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 399  Variable mirrored-link          \ linked Line 442  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" $has? 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 422  Variable mirrored-link          \ linked Line 466  Variable mirrored-link          \ linked
 0 0 region dictionary  0 0 region dictionary
 \ rom area for the compiler  \ rom area for the compiler
   
 has? rom   T has? rom H
 [IF]  [IF]
 0 0 region ram-dictionary mirrored  0 0 region ram-dictionary mirrored
 \ ram area for the compiler  \ ram area for the compiler
Line 440  has? rom Line 484  has? rom
   
   
 : setup-target ( -- )   \G initialize targets memory space  : setup-target ( -- )   \G initialize targets memory space
   s" rom" $has?    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 454  has? rom Line 498  has? rom
   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 492  variable fixed  \ flag: true: no automat Line 555  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 has-rom 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 517  variable constflag constflag off Line 584  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 549  bigendian Line 616  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 565  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 665  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
   ' (correcter) IS >image
   [THEN]
   
 \ Target memory access                                 06oct92py  \ Target memory access                                 06oct92py
   
Line 584  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 703  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 600  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 716  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 633  previous Line 752  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 656  DEFER >body             \ we need the sy Line 796  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 666  DEFER dodoes, Line 806  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, ;
 >CROSS  >CROSS
   
   \ file loading
   
   : >fl-id   1 cells + ;
   : >fl-name 2 cells + ;
   
   Variable filelist 0 filelist !
   Create NoFile ," #load-file#"
   0 Value  filemem
   : loadfile  FileMem ?dup IF >fl-name ELSE NoFile THEN ;
   
   1 [IF] \ !! JAW WIP
   
   : add-included-file ( adr len -- )
           dup char+ >fl-name allocate throw >r
           r@ >fl-name place
           filelist @ r@ !
           r> dup filelist ! to FileMem
           ;
   
   : included? ( c-addr u -- f )
           filelist
           BEGIN   @ dup
           WHILE   >r r@ 1 cells + count compare 0=
                   IF rdrop 2drop true EXIT THEN
                   r>
           REPEAT
           2drop drop false ;      
   
   : included 
   \       cr ." Including: " 2dup type ." ..."
           FileMem >r
           2dup add-included-file included 
           r> to FileMem ;
   
   : include bl word count included ;
   
   : require bl word count included ;
   
   [THEN]
   
 \ 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 + ;
   : >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 -- )
   swap >r here r@ >link @ , r@ >link ! ( tag ) ,  \G creates a resolve structure
   T here aligned H , r> drop  last-header-ghost @ , ;      T here aligned H swap (refered)
     ;
   
   : 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 700  Defer resolve-warning Line 915  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 736  Exists-Warnings on Line 955  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 768  variable ResolveFlag Line 997  variable ResolveFlag
 : ?touched ( ghost -- flag ) dup forward? swap >link @  : ?touched ( ghost -- flag ) dup forward? swap >link @
                                0 <> and ;                                 0 <> and ;
   
   : .forwarddefs ( ghost -- )
           ."  appeared in:"
           >link
           BEGIN   @ dup
           WHILE   cr 5 spaces
                   dup >ghost @ >ghostname type
                   ."  file " dup >file @ ?dup IF count type ELSE ." CON" THEN
                   ."  line " dup >line @ .dec
           REPEAT 
           drop ;
   
 : ?resolved  ( ghostname -- )  : ?resolved  ( ghostname -- )
   dup cell+ @ ?touched    dup cell+ @ ?touched
   IF  cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ;    IF    dup 
           cell+ cell+ count cr type ResolveFlag on 
           cell+ @ .forwarddefs
     ELSE  drop 
     THEN ;
   
 >MINIMAL  >MINIMAL
 : .unresolved  ( -- )  : .unresolved  ( -- )
Line 789  variable ResolveFlag Line 1033  variable ResolveFlag
 : .stats  : .stats
   base @ >r decimal    base @ >r decimal
   cr ." named Headers: " headers-named @ .     cr ." named Headers: " headers-named @ . 
 \  cr ." MaxRam*" ramdp @ .   
 \  cr ." MaxRom*" romdp @ .   
   r> base ! ;    r> base ! ;
   
 >CROSS  >CROSS
Line 807  VARIABLE ^imm Line 1049  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 827  VARIABLE ^imm Line 1072  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 912  Defer skip? ' false IS skip? Line 1157  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 923  VARIABLE CreateFlag CreateFlag off Line 1174  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 958  VARIABLE ;Resolve 1 cells allot Line 1219  VARIABLE ;Resolve 1 cells allot
 >TARGET  >TARGET
 : Alias    ( cfa -- ) \ name  : Alias    ( cfa -- ) \ name
     >in @ skip? IF  2drop  EXIT  THEN  >in !      >in @ skip? IF  2drop  EXIT  THEN  >in !
     dup 0< has-prims 0= and      dup 0< s" prims" T $has? H 0= and
     IF      IF
         ." needs prim: " >in @ bl word count type >in ! cr          .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
     THEN      THEN
     (THeader over resolve T A, H 80 flag! ;      (THeader over resolve T A, H 80 flag! ;
 : Alias:   ( cfa -- ) \ name  : Alias:   ( cfa -- ) \ name
     >in @ skip? IF  2drop  EXIT  THEN  >in !      >in @ skip? IF  2drop  EXIT  THEN  >in !
     dup 0< has-prims 0= and      dup 0< s" prims" T $has? H 0= and
     IF      IF
         ." 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 1032  Cond: [']  T ' H alit, ;Cond Line 1298  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 1053  Cond: [']  T ' H alit, ;Cond Line 1319  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 1066  Defer (end-code) Line 1338  Defer (end-code)
 : Code  : Code
   defempty?    defempty?
   (THeader there resolve    (THeader there resolve
   [ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF]    [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]
   doprim,     doprim, 
   [THEN]    [THEN]
   depth (code) ;    depth (code) ;
Line 1082  Defer (end-code) Line 1354  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 1147  Cond: MAXI Line 1419  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 1191  Cond: ; ( -- ) restrict? Line 1464  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 1221  Cond: DOES> restrict? Line 1501  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 1231  Cond: DOES> restrict? Line 1514  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 1268  Cond: DOES> restrict? Line 1555  Cond: DOES> restrict?
   
 : BuildSmart:  ( -- [xt] [colon-sys] )  : BuildSmart:  ( -- [xt] [colon-sys] )
   :noname    :noname
   [ has-rom [IF] ]    [ T has? rom H [IF] ]
   postpone RTCreate    postpone RTCreate
   [ [ELSE] ]    [ [ELSE] ]
   postpone TCreate     postpone TCreate 
Line 1320  BuildSmart: ; Line 1607  BuildSmart: ;
 by: :dovar ( ghost -- addr ) ;DO  by: :dovar ( ghost -- addr ) ;DO
 Builder Create  Builder Create
   
 has-rom [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 1330  by Create Line 1617  by Create
 Builder Variable  Builder Variable
 [THEN]  [THEN]
   
 has-rom [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 1408  Builder Field Line 1705  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  \ structural conditionals                              17dec92py
   
 >CROSS  >CROSS
Line 1417  Builder Field Line 1712  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 ;
   
 : <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, ( target-addr -- )
   :noname compile ?branch T here branchoffset , H ;
     IS ?branch, ( target-addr -- )
   :noname compile branch T here 0 , H ;
     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
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
Line 1427  Builder Field Line 1740  Builder Field
 Cond: BUT       restrict? sys? swap ;Cond  Cond: BUT       restrict? sys? swap ;Cond
 Cond: YET       restrict? sys? dup ;Cond  Cond: YET       restrict? sys? dup ;Cond
   
   0 [IF]
 >CROSS  >CROSS
 Variable tleavings  Variable tleavings
 >TARGET  >TARGET
Line 1436  Cond: DONE   ( addr -- )  restrict? tlea Line 1750  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
   
 \ 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  
   
   [ELSE]
       \ !! This is WIP
       \ The problem is (?DO)!
       \ perhaps we need a plug-in for (?DO)
       
 >CROSS  >CROSS
 : loop]   dup <resolve tcell - compile DONE compile unloop ;  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: LOOP      restrict? sys? compile (loop)  loop] ;Cond  Cond: DONE   ( addr -- )  restrict? (done) ;Cond
 Cond: +LOOP     restrict? sys? compile (+loop) loop] ;Cond  
 Cond: NEXT      restrict? sys? compile (next)  loop] ;Cond  >CROSS
   : (leave) ( branchtoken -- )
       3 cells allocate throw >r
       T here H r@ cell+ !
       r@ 2 cells + !
       tleavings @ r@ !
       r> tleavings ! ;
   >TARGET
   
 [ELSE]  Cond: LEAVE     restrict? branchmark, (leave) ;Cond
   Cond: ?LEAVE    restrict? compile 0=  ?branchmark, (leave)  ;Cond
   
 \ structural conditionals                              17dec92py  [THEN]
   
 >CROSS  >CROSS
 : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;  \ !!JW ToDo : Move to general tools section
 : sys?        ( sys -- sys )    dup 0= ?struc ;  
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;  
   
 : branchoffset ( src dest -- ) - ;  : 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 ;
   
 : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;  : loop]     branchto, dup <resolve tcell - (done) ;
   
 : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;  
   
 :noname compile branch T here branchoffset , H ; IS branch,  : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
 :noname compile ?branch T here branchoffset , H ; IS ?branch,  
 :noname compile branch T here 0 , H ; IS branchmark,  
 :noname compile ?branch T here 0 , H ; IS  ?branchmark,  
 :noname dup T @ H ?struc T here over branchoffset swap ! H ; IS branchtoresolve,  
 :noname branchto, T here H ; IS branchtomark,  
   
 >TARGET  >TARGET
   
 \ Structural Conditionals                              12dec92py  \ 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  >TARGET
   
 Cond: LEAVE     restrict? compile branch (leave ;Cond  
 Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave  ;Cond  
   
 \ Structural Conditionals                              12dec92py  
   
 Cond: AHEAD     restrict? branchmark, ;Cond  Cond: AHEAD     restrict? branchmark, ;Cond
 Cond: IF        restrict? ?branchmark, ;Cond  Cond: IF        restrict? ?branchmark, ;Cond
 Cond: THEN      restrict? sys? branchto, branchtoresolve, ;Cond  Cond: THEN      restrict? sys? branchto, branchtoresolve, ;Cond
Line 1540  Cond: ENDCASE   restrict? compile drop 0 Line 1836  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]   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 1563  Cond: S"        restrict? compile (S") Line 1877  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 1594  Cond: compile ( -- ) restrict? \ name Line 1908  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 1627  also minimal Line 1990  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 1660  Cond: \D \D ;Cond Line 2027  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 1706  char 1 bigendian + tcell + magic 7 + c! Line 2072  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 1718  also minimal Line 2084  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 1725  bigendian Constant bigendian Line 2095  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.52  
changed lines
  Added in v.1.67


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