gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.107 and 1.149

-version 1.107, Wed Sep  5 11:01:27 2001 UTC
+version 1.149, Sun Aug 21 22:09:14 2005 UTC
  Line 1
  Line 1
  Line 1
  \ CROSS.FS     The Cross-Compiler                      06oct92py
  \ Idea and implementation: Bernd Paysan (py)
- \ Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.
+ \ Copyright (C) 1995,1996,1997,1998,1999,2000,2003,2004 Free Software Foundation, Inc.
  \ This file is part of Gforth.
  Line 27
  Line 27
  Line 27
    cross.fs is used seperately. jaw
  - Do we need this char translation with >address and in branchoffset?
    (>body also affected) jaw
- - MAXU etc. can be done with dlit,
  [THEN]
+ s" compat/strcomp.fs" included
  hex
  \ debugging for compiling
- Line 71
+ Line 72
  Line 71
  Line 72
  >CROSS
+ \ Test against this definitions to find out whether we are cross-compiling
+ \ may be usefull for assemblers
+Constant gforth-cross-indicator
  \ find out whether we are compiling with gforth
  : defined? bl word find nip ;
- Line 202
+ Line 207
  Line 202
  Line 207
  [THEN]
+ \ this provides assert( and struct stuff
+ \GFORTH [IFUNDEF] assert1(
+ \GFORTH also forth definitions require assert.fs previous
+ \GFORTH [THEN]
+ >CROSS
  hex     \ the defualt base for the cross-compiler is hex !!
  \ Warnings off
- Line 242
+ Line 254
  Line 242
  Line 254
  hex
+ \ FIXME delete`
  \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are
                          \ for cross-compiling
  \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!
+ \ FIXME move down
  : comment? ( c-addr u -- c-addr u )
-dup s" (" compare 0=
+dup s" (" str=
          IF    postpone (
-         ELSE  2dup s" \" compare 0= IF postpone \ THEN
+         ELSE  2dup s" \" str= IF postpone \ THEN
          THEN ;
- : X     bl word count [ ' target >wordlist ] Literal search-wordlist
+ : X ( -- <name> )
-         IF      state @ IF compile,
+ \G The next word in the input is a target word.
-                 ELSE execute THEN
+ \G Equivalent to T <name> but without permanent
+ \G switch to target dictionary. Used as prefix e.g. for @, !, here etc.
+   bl word count [ ' target >wordlist ] Literal search-wordlist
+   IF state @ IF compile, ELSE execute THEN
          ELSE    -1 ABORT" Cross: access method not supported!"
          THEN ; immediate
- Line 303
+ Line 320
  Line 303
  Line 320
          \ POSTPONE false
    THEN ; immediate
+ : symentry ( adr len taddr -- )
+ \G Produce a symbol table (an optional symbol address
+ \G map) if wanted
+     [ [IFDEF] fd-symbol-table ]
+       base @ swap hex s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base !
+       s" :" fd-symbol-table write-file throw
+       fd-symbol-table write-line throw
+     [ [ELSE] ]
+drop drop
+     [ [THEN] ] ;
  \ \ --------------------        source file
  decimal
- Line 418
+ Line 447
  Line 418
  Line 447
      \G Make a complete new Forth search path; the path separator is |.
      fpath path= ;
- : path>counted  cell+ dup cell+ swap @ ;
+ : path>string  cell+ dup cell+ swap @ ;
  : next-path ( adr len -- adr2 len2 )
 dup 0 scan
- Line 427
+ Line 456
  Line 427
  Line 456
    r> - ;
  : previous-path ( path^ -- )
-   dup path>counted
+   dup path>string
    BEGIN tuck dup WHILE repeat ;
  : .path ( path-addr -- ) \ gforth
      \G Display the contents of the search path @var{path-addr}.
-     path>counted
+     path>string
      BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ;
  : .fpath ( -- ) \ gforth
- Line 447
+ Line 476
  Line 447
  Line 476
 dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/....
      over c@ [char] / = >r
      over c@ [char] ~ = >r
-     \ 2dup 3 min S" ../" compare 0= r> or >r \ not catered for in expandtopic
+     \ 2dup S" ../" string-prefix? r> or >r \ not catered for in expandtopic
-min S" ./" compare 0=
+     S" ./" string-prefix?
      r> r> r> or or or ;
  Create ofile 0 c, 255 chars allot
- Line 464
+ Line 493
  Line 464
  Line 493
    REPEAT ;
  : remove~+ ( -- )
-     ofile count 3 min s" ~+/" compare 0=
+     ofile count s" ~+/" string-prefix?
      IF
          ofile count 3 /string ofile place
      THEN ;
  : expandtopic ( -- ) \ stack effect correct? - anton
      \ expands "./" into an absolute name
-     ofile count 2 min s" ./" compare 0=
+     ofile count s" ./" string-prefix?
      IF
          ofile count 1 /string tfile place
 ofile c! sourcefilename extractpath ofile place
- Line 484
+ Line 513
  Line 484
  Line 513
      \ deletes phrases like "xy/.." out of our directory name 2dec97jaw
      over swap
      BEGIN  dup  WHILE
-         dup >r '/ scan 2dup 4 min s" /../" compare 0=
+         dup >r '/ scan 2dup s" /../" string-prefix?
          IF
              dup r> - >r 4 /string over r> + 4 -
              swap 2dup + >r move dup r> over -
- Line 517
+ Line 546
  Line 517
  Line 546
    IF    rdrop
          ofile place open-ofile
          dup 0= IF >r ofile count r> THEN EXIT
-   ELSE  r> path>counted
+   ELSE  r> path>string
          BEGIN  next-path dup
          WHILE  5 pick 5 pick check-path
 = IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN
- Line 547
+ Line 576
  Line 547
  Line 576
  : included? ( c-addr u -- f )
    file-list
    BEGIN @ dup
-   WHILE >r 2dup r@ >fl-name count compare 0=
+   WHILE >r 2dup r@ >fl-name count str=
          IF rdrop 2drop true EXIT THEN
          r>
    REPEAT
- Line 633
+ Line 662
  Line 633
  Line 662
  : defempty? empty? ;
  [ELSE]
  : defempty? ; immediate
+ \ : defempty? .sourcepos ;
  [THEN]
  \ \ --------------------        Compiler Plug Ins               01aug97jaw
- Line 738
+ Line 768
  Line 738
  Line 768
  Plugin leave,   ( -- )
  Plugin ?leave,  ( -- )
- [IFUNDEF] ca>native
+ Plugin ca>native  \ Convert a code address to the processors
- Plugin ca>native
+                   \ native address. This is used in doprim, and
- [THEN]
+                   \ code/code: primitive definitions word to
+                   \ convert the addresses.
+                   \ The only target where we need this is the misc
+                   \ which is a 16 Bit processor with word addresses
+                   \ but the forth system we build has a normal byte
+                   \ addressed memory model
  Plugin doprim,  \ compiles start of a primitive
  Plugin docol,           \ compiles start of a colon definition
- Line 986
+ Line 1021
  Line 986
  Line 1021
  Variable reuse-ghosts reuse-ghosts off
-[IF] \ FIXME: define when vocs are ready
  : HeaderGhost ( "name" -- ghost )
    >in @
    bl word count
- Line 1003
+ Line 1037
  Line 1003
  Line 1037
    \ defined words, this is a workaround
    \ for the redefined \ until vocs work
    Make-Ghost ;
- [THEN]
  : .ghost ( ghost -- ) >ghostname type ;
  \ ' >ghostname ALIAS @name
+ : findghost ( "ghostname" -- ghost )
+   bl word gfind 0= ABORT" CROSS: Ghost don't exists" ;
  : [G'] ( -- ghost : name )
  \G ticks a ghost and returns its address
- \  bl word gfind 0= ABORT" CROSS: Ghost don't exists"
+   findghost
-   ghost state @ IF postpone literal THEN ; immediate
+   state @ IF postpone literal THEN ; immediate
  : g>xt ( ghost -- xt )
  \G Returns the xt (cfa) of a ghost. Issues a warning if undefined.
- Line 1044
+ Line 1079
  Line 1044
  Line 1079
    dup @ ?dup IF nip EXIT THEN
    addr-struct %allocerase tuck swap ! ;
+ >cross
  \ Predefined ghosts                                    12dec92py
+ Ghost - drop \ need a ghost otherwise "-" would be treated as a number
  Ghost 0=                                        drop
  Ghost branch    Ghost ?branch                   2drop
- Ghost (do)      Ghost (?do)                     2drop
- Ghost (for)                                     drop
- Ghost (loop)    Ghost (+loop)                   2drop
- Ghost (next)                                    drop
  Ghost unloop    Ghost ;S                        2drop
- Ghost lit       Ghost (compile) Ghost !         2drop drop
+ Ghost lit       Ghost !                         2drop
- Ghost (does>)   Ghost noop                      2drop
+ Ghost noop                                      drop
- Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
- Ghost '                                         drop
- Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop
- Ghost :dovar                                    drop
  Ghost over      Ghost =         Ghost drop      2drop drop
- Ghost - drop
  Ghost 2drop drop
  Ghost 2dup drop
+ Ghost call drop
+ Ghost @ drop
+ Ghost useraddr drop
+ Ghost execute drop
+ Ghost + drop
+ Ghost decimal drop
+ Ghost hex drop
+ Ghost lit@ drop
+ Ghost lit-perform drop
+ Ghost lit+ drop
+ Ghost does-exec drop
+ Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop
+ Ghost :dovar                                    drop
  \ \ Parameter for target systems                         06oct92py
- >cross
  \ we define it ans like...
  wordlist Constant target-environment
- Line 1134
+ Line 1175
  Line 1134
  Line 1175
  false DefaultValue backtrace
  false DefaultValue new-input
  false DefaultValue peephole
+ false DefaultValue abranch
+ true DefaultValue f83headerstring
+ true DefaultValue control-rack
  [THEN]
+ true DefaultValue gforthcross
  true DefaultValue interpreter
  true DefaultValue ITC
  false DefaultValue rom
  true DefaultValue standardthreading
+ \ ANSForth environment  stuff
+DefaultValue ADDRESS-UNIT-BITS
+DefaultValue MAX-CHAR
+DefaultValue /COUNTED-STRING
  >TARGET
  s" relocate" T environment? H
  \ JAW why set NIL to this?!
  [IF]    drop \ SetValue NIL
- [ELSE]  >ENVIRON T NIL H SetValue relocate
+ [ELSE]  >ENVIRON X NIL SetValue relocate
  [THEN]
+ >TARGET
+Constant NIL
  >CROSS
- Line 1192
+ Line 1245
  Line 1192
  Line 1245
  \ Variables                                            06oct92py
- Variable image
+ Variable (tlast)
- Variable tlast    TNIL tlast !  \ Last name field
+ (tlast) Value tlast TNIL tlast !  \ Last name field
  Variable tlastcfa \ Last code field
- Variable bit$
  \ statistics                                            10jun97jaw
- Line 1217
+ Line 1269
  Line 1217
  Line 1269
  Variable mirrored-link          \ linked list for mirrored regions
 dup mirrored-link ! region-link !
+ : >rname 9 cells + ;
- : >rname 7 cells + ;
+ : >rtouch 8 cells + ; \ executed when region is accessed
- : >rbm   4 cells + ;
+ : >rbm   4 cells + ; \ bitfield per cell witch indicates relocation
  : >rmem  5 cells + ;
- : >rtype 6 cells + ;
+ : >rtype 6 cells + ; \ field per cell witch points to a type struct
+ : >rrom 7 cells + ;  \ a -1 indicates that this region is rom
  : >rlink 3 cells + ;
  : >rdp 2 cells + ;
  : >rlen cell+ ;
  : >rstart ;
+ : (region) ( addr len region -- )
+ \G change startaddress and length of an existing region
+   >r r@ last-defined-region !
+   r@ >rlen ! dup r@ >rstart ! r> >rdp ! ;
+ : uninitialized -1 ABORT" CROSS: Region is uninitialized" ;
- : region ( addr len -- )
+ : region ( addr len -- "name" )
  \G create a new region
    \ check whether predefined region exists
    save-input bl word find >r >r restore-input throw r> r> 0=
- Line 1237
+ Line 1296
  Line 1237
  Line 1296
          save-input create restore-input throw
          here last-defined-region !
          over ( startaddr ) , ( length ) , ( dp ) ,
-         region-link linked 0 , 0 , 0 , bl word count string,
+         region-link linked 0 , 0 , 0 , 0 ,
+         ['] uninitialized ,
+         bl word count string,
    ELSE  \ store new parameters in region
          bl word drop
-         >body >r r@ last-defined-region !
+         >body (region)
-         r@ >rlen ! dup r@ >rstart ! r> >rdp !
    THEN ;
  : borders ( region -- startaddr endaddr )
- Line 1256
+ Line 1316
  Line 1256
  Line 1316
  \G returns the total area
    dup >rstart @ swap >rlen @ ;
- : mirrored
+ : dp@ ( region -- dp )
- \G mark a region as mirrored
+   >rdp @ ;
+ : mirrored ( -- )
+ \G mark last defined region as mirrored
    mirrored-link
    align linked last-defined-region @ , ;
+ : writeprotected
+ \G mark a region as write protected
+   -1 last-defined-region @ >rrom ! ;
  : .addr ( u -- )
  \G prints a 16 or 32 Bit nice hex value
    base @ >r hex
- Line 1297
+ Line 1364
  Line 1297
  Line 1364
 0 region address-space
  \ total memory addressed and used by the target system
+0 region user-region
+ \ data for user variables goes here
+ \ this has to be defined before dictionary or ram-dictionary
 0 region dictionary
  \ rom area for the compiler
- Line 1316
+ Line 1387
  Line 1316
  Line 1387
  ' dictionary ALIAS rom-dictionary
+ : setup-region ( region -- )
+   >r
+   \ allocate mem
+   r@ >rlen @ allocatetarget
+   r@ >rmem !
+   r@ >rlen @
+   target>bitmask-size allocatetarget
+   r@ >rbm !
+   r@ >rlen @
+   tcell / 1+ cells allocatetarget r@ >rtype !
+   ['] noop r@ >rtouch !
+   rdrop ;
  : setup-target ( -- )   \G initialize target's memory space
    s" rom" T $has? H
- Line 1341
+ Line 1427
  Line 1341
  Line 1427
    WHILE dup
 >rlink - >r
          r@ >rlen @
-         IF      \ allocate mem
+         IF      r@ setup-region
-                 r@ >rlen @ allocatetarget dup image !
+         THEN    rdrop
-                 r@ >rmem !
-                 r@ >rlen @
-                 target>bitmask-size allocatetarget
-                 dup bit$ !
-                 r@ >rbm !
-                 r@ >rlen @
-                 tcell / 1+ cells allocatetarget r@ >rtype !
-                 rdrop
-         ELSE    r> drop THEN
     REPEAT drop ;
  \ MakeKernel                                                    22feb99jaw
- : makekernel ( targetsize -- targetsize )
+ : makekernel ( start targetsize -- )
-   dup dictionary >rlen ! setup-target ;
+ \G convenience word to setup the memory of the target
+ \G used by main.fs of the c-engine based systems
+   dictionary (region) setup-target ;
  >MINIMAL
  : makekernel makekernel ;
- Line 1385
+ Line 1461
  Line 1385
  Line 1461
  [THEN]
+Value current-region
-value tdp
+Value tdp
- variable fixed          \ flag: true: no automatic switching
+ Variable fixed          \ flag: true: no automatic switching
                          \       false: switching is done automatically
  \ Switch-Policy:
- Line 1402
+ Line 1478
  Line 1402
  Line 1478
  : activate ( region -- )
  \G next code goes to this region
-   >rdp to tdp ;
+   dup to current-region >rdp to tdp ;
  : (switchram)
    fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT
- Line 1488
+ Line 1564
  Line 1488
  Line 1564
 >rlink - >r
          r@ >rlen @
          IF      dup r@ borders within
-                 IF r> r> drop nip EXIT THEN
+                 IF r> r> drop nip
+                    dup >rtouch @ EXECUTE EXIT
+                 THEN
          THEN
          r> drop
          r>
- Line 1496
+ Line 1574
  Line 1496
  Line 1574
 drop 0 ;
  : taddr>region-abort ( taddr -- region | 0 )
+ \G Same as taddr>region but aborts if taddr is not
+ \G a valid address in the target address space
    dup taddr>region dup 0=
    IF    drop cr ." Wrong address: " .addr
          -1 ABORT" Address out of range!"
- Line 1511
+ Line 1591
  Line 1511
  Line 1591
    \ add regions real address in our memory
    r> >rmem @ + ;
+ : (>regionramimage) ( taddr -- 'taddr )
+ \G same as (>regionimage) but aborts if the region is rom
+   dup
+   \ find region we want to address
+   taddr>region-abort
+   >r
+   r@ >rrom @ ABORT" CROSS: region is write-protected!"
+   \ calculate offset in region
+   r@ >rstart @ -
+   \ add regions real address in our memory
+   r> >rmem @ + ;
  : (>regionbm) ( taddr -- 'taddr bitmaskbaseaddr )
    dup
    \ find region we want to address
- Line 1556
+ Line 1648
  Line 1556
  Line 1648
    [ [THEN] ]
    (>regionbm) swap cell/ -bit ;
- : (>image) ( taddr -- absaddr ) image @ + ;
  DEFER >image
+ DEFER >ramimage
  DEFER relon
  DEFER reloff
  DEFER correcter
- Line 1568
+ Line 1659
  Line 1568
  Line 1659
  ' (relon) IS relon
  ' (reloff) IS reloff
  ' (>regionimage) IS >image
+ ' (>regionimage) IS >ramimage
  [ELSE]
  ' drop IS relon
  ' drop IS reloff
  ' (>regionimage) IS >image
+ ' (>regionimage) IS >ramimage
  [THEN]
+ : enforce-writeprotection ( -- )
+   ['] (>regionramimage) IS >ramimage ;
+ : relax-writeprotection ( -- )
+   ['] (>regionimage) IS >ramimage ;
+ : writeprotection-relaxed? ( -- )
+   ['] >ramimage >body @ ['] (>regionimage) = ;
  \ Target memory access                                 06oct92py
  : align+  ( taddr -- rest )
- Line 1591
+ Line 1693
  Line 1591
  Line 1693
      dup cfalign+ + ;
  : @  ( taddr -- w )     >image S@ ;
- : !  ( w taddr -- )     >image S! ;
+ : !  ( w taddr -- )     >ramimage S! ;
  : c@ ( taddr -- char )  >image Sc@ ;
- : c! ( char taddr -- )  >image Sc! ;
+ : c! ( char taddr -- )  >ramimage Sc! ;
  : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
  : 2! ( x1 x2 taddr -- ) T tuck ! cell+ ! H ;
- Line 1612
+ Line 1714
  Line 1612
  Line 1714
  : A!                    swap >address swap dup relon T ! H ;
  : A,    ( w -- )        >address T here H relon T , H ;
+ \ high-level ghosts
+ >CROSS
+ Ghost (do)      Ghost (?do)                     2drop
+ Ghost (for)                                     drop
+ Ghost (loop)    Ghost (+loop)                   2drop
+ Ghost (next)                                    drop
+ Ghost (does>)   Ghost (does>1)  Ghost (does>2)  2drop drop
+ Ghost compile,                                  drop
+ Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
+ Ghost (C")      Ghost c(abort") Ghost type      2drop drop
+ Ghost '                                         drop
+ \ user ghosts
+ Ghost state drop
  \ \ --------------------        Host/Target copy etc.           29aug01jaw
- Line 1636
+ Line 1755
  Line 1636
  Line 1755
  : ht-string,  ( addr count -- )
    dup there swap last-string 2!
    dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;
+ : ht-mem, ( addr count )
+     bounds ?DO  I c@  T c, H  LOOP ;
  >TARGET
  : count dup X c@ swap X char+ swap ;
- \ FIXME -1 on 64 bit machines?!?!
- : on            T -1 swap ! H ;
+ : on            >r -1 -1 r> TD!  ;
  : off           T 0 swap ! H ;
  : tcmove ( source dest len -- )
- Line 1672
+ Line 1793
  Line 1672
  Line 1793
  : (cc) T a, H ;                                 ' (cc) plugin-of colon,
  : (prim) T a, H ;                               ' (prim) plugin-of prim,
- : (cr) >tempdp ]comp prim, comp[ tempdp> ;      ' (cr) plugin-of colon-resolve
+ : (cr) >tempdp colon, tempdp> ;                 ' (cr) plugin-of colon-resolve
  : (ar) T ! H ;                                  ' (ar) plugin-of addr-resolve
  : (dr)  ( ghost res-pnt target-addr addr )
          >tempdp drop over
- Line 1683
+ Line 1804
  Line 1683
  Line 1804
          tempdp> ;                               ' (dr) plugin-of doer-resolve
  : (cm) ( -- addr )
-     T here align H
+     there -1 colon, ;                           ' (cm) plugin-of colonmark,
-     -1 colon, ;                                 ' (cm) plugin-of colonmark,
  >TARGET
  : compile, ( xt -- )
- Line 1769
+ Line 1889
  Line 1769
  Line 1889
    >link ! ;
  : colon-resolved   ( ghost -- )
-     >link @ colon, ; \ compile-call
+ \ compiles a call to a colon definition,
+ \ compile action for >comp field
+     >link @ colon, ;
  : prim-resolved  ( ghost -- )
+ \ compiles a call to a primitive
      >link @ prim, ;
- \ FIXME: not activated
- : does-resolved ( ghost -- )
-     dup g>body alit, >do:ghost @ g>body colon, ;
  : (is-forward)   ( ghost -- )
    colonmark, 0 (refered) ; \ compile space for call
  ' (is-forward) IS is-forward
- : resolve  ( ghost tcfa -- )
+Value resolved
- \G resolve referencies to ghost with tcfa
+ : resolve-forward-references ( ghost resolve-list -- )
+     \ loop through forward referencies
+     comp-state @ >r Resolving comp-state !
+     over >link @ resolve-loop
+     r> comp-state !
+     ['] noop IS resolve-warning ;
+ : (resolve) ( ghost tcfa -- ghost resolve-list )
+     \ check for a valid address, it is a primitive reference
+     \ otherwise
      dup taddr>region 0<> IF
+       \ define this address in the region address type table
 dup (>regiontype) define-addr-struct addr-xt-ghost
        \ we define new address only if empty
        \ this is for not to take over the alias ghost
        \ (different ghost, but identical xt)
        \ but the very first that really defines it
        dup @ 0= IF ! ELSE 2drop THEN
      THEN
+     swap >r
+     r@ to resolved
+ \    r@ >comp @ ['] is-forward =
+ \    ABORT" >comp action not set on a resolved ghost"
+     \ copmile action defaults to colon-resolved
+     \ if this is not right something must be set before
+     \ calling resolve
+     r@ >comp @ ['] is-forward = IF
+        ['] colon-resolved r@ >comp !
+    THEN
+     r@ >link @ swap \ ( list tcfa R: ghost )
+     \ mark ghost as resolved
+     r@ >link ! <res> r@ >magic !
+     r> swap ;
+ : resolve  ( ghost tcfa -- )
+ \G resolve referencies to ghost with tcfa
      \ is ghost resolved?, second resolve means another
      \ definition with the same name
      over undefined? 0= IF  exists EXIT THEN
-     \ get linked-list
+     (resolve)
-     swap >r r@ >link @ swap \ ( list tcfa R: ghost )
+     ( ghost resolve-list )
-     \ mark ghost as resolved
+     resolve-forward-references ;
-     dup r@ >link ! <res> r@ >magic !
-     r@ >comp @ ['] is-forward = IF
+ : resolve-noforwards ( ghost tcfa -- )
-         ['] prim-resolved  r@ >comp !  THEN
+ \G Same as resolve but complain if there are any
-     \ loop through forward referencies
+ \G forward references on this ghost
-     r> -rot
+    \ is ghost resolved?, second resolve means another
-     comp-state @ >r Resolving comp-state !
+    \ definition with the same name
-     resolve-loop
+    over undefined? 0= IF  exists EXIT THEN
-     r> comp-state !
+    (resolve)
+    IF cr ." No forward references allowed on: " .ghost cr
-     ['] noop IS resolve-warning
+       -1 ABORT" Illegal forward reference"
-   ;
+    THEN
+    drop ;
  \ gexecute ghost,                                      01nov92py
- \ FIXME cleanup
- \ : is-resolved   ( ghost -- )
- \  >link @ colon, ; \ compile-call
  : (gexecute)   ( ghost -- )
    dup >comp @ EXECUTE ;
  : gexecute ( ghost -- )
-   dup >magic @ <imm> = IF -1 ABORT" CROSS: gexecute on immediate word" THEN
+   dup >magic @ <imm> = ABORT" CROSS: gexecute on immediate word"
    (gexecute) ;
  : addr,  ( ghost -- )
    dup forward? IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;
- \ !! : ghost,     ghost  gexecute ;
  \ .unresolved                                          11may93jaw
  variable ResolveFlag
- Line 1883
+ Line 2027
  Line 1883
  Line 2027
  \ Header states                                        12dec92py
  \ : flag! ( 8b -- )   tlast @ dup >r T c@ xor r> c! H ;
- bigendian [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+
+ X has? f83headerstring bigendian or [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+
  : flag! ( w -- )   tlast @ flag+ + dup >r T c@ xor r> c! H ;
  VARIABLE ^imm
- Line 1912
+ Line 2056
  Line 1912
  Line 2056
    dup T , H bounds  ?DO  I c@ T c, H  LOOP ;
  >TARGET
+ X has? f83headerstring [IF]
+ : name,  ( "name" -- )  bl word count ht-string, X cfalign ;
+ [ELSE]
  : name,  ( "name" -- )  bl word count ht-lstring, X cfalign ;
+ [THEN]
  : view,   ( -- ) ( dummy ) ;
  >CROSS
- Line 1946
+ Line 2094
  Line 1946
  Line 2094
  \ Target TAGS creation
  s" kernel.TAGS" r/w create-file throw value tag-file-id
+ s" kernel.tags" r/w create-file throw value vi-tag-file-id
  \ contains the file-id of the tags file
- Create tag-beg 2 c,  7F c, bl c,
+ Create tag-beg 1 c,  7F c,
- Create tag-end 2 c,  bl c, 01 c,
+ Create tag-end 1 c,  01 c,
  Create tag-bof 1 c,  0C c,
+ Create tag-tab 1 c,  09 c,
 variable last-loadfilename 0 0 last-loadfilename 2!
- Line 1964
+ Line 2114
  Line 1964
  Line 2114
          s" ,0" tag-file-id write-line throw
      THEN ;
- : cross-tag-entry  ( -- )
+ : cross-gnu-tag-entry  ( -- )
      tlast @ 0<> \ not an anonymous (i.e. noname) header
      IF
          put-load-file-name
          source >in @ min tag-file-id write-file throw
          tag-beg count tag-file-id write-file throw
-         tlast @ >image count 1F and tag-file-id write-file throw
+         Last-Header-Ghost @ >ghostname tag-file-id write-file throw
          tag-end count tag-file-id write-file throw
          base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw
  \       >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
- Line 1978
+ Line 2128
  Line 1978
  Line 2128
          base !
      THEN ;
+ : cross-vi-tag-entry ( -- )
+     tlast @ 0<> \ not an anonymous (i.e. noname) header
+     IF
+         sourcefilename vi-tag-file-id write-file throw
+         tag-tab count vi-tag-file-id write-file throw
+         Last-Header-Ghost @ >ghostname vi-tag-file-id write-file throw
+         tag-tab count vi-tag-file-id write-file throw
+         s" /^" vi-tag-file-id write-file throw
+         source vi-tag-file-id write-file throw
+         s" $/" vi-tag-file-id write-line throw
+     THEN ;
+ : cross-tag-entry ( -- )
+     cross-gnu-tag-entry
+     cross-vi-tag-entry ;
  \ Check for words
  Defer skip? ' false IS skip?
- Line 2012
+ Line 2178
  Line 2012
  Line 2178
 =
      ELSE  drop true  THEN ;
- : doer? ( -- flag ) \ name
+ : doer? ( "name" -- 0 | addr ) \ name
-     Ghost >magic @ <do:> = ;
+     Ghost dup >magic @ <do:> =
+     IF >link @ ELSE drop 0 THEN ;
  : skip-defs ( -- )
      BEGIN  refill  WHILE  source -trailing nip 0= UNTIL  THEN ;
- Line 2038
+ Line 2205
  Line 2038
  Line 2205
          ENDCASE
      LOOP ;
- Defer setup-execution-semantics
+ Defer setup-execution-semantics  ' noop IS setup-execution-semantics
 Value lastghost
  : (THeader ( "name" -- ghost )
- Line 2059
+ Line 2226
  Line 2059
  Line 2226
  \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !
      HeaderGhost
      \ output symbol table to extra file
-     [ [IFDEF] fd-symbol-table ]
+     dup >ghostname there symentry
-       base @ hex there s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base !
-       s" :" fd-symbol-table write-file throw
-       dup >ghostname fd-symbol-table write-line throw
-     [ [THEN] ]
      dup Last-Header-Ghost ! dup to lastghost
      dup >magic ^imm !     \ a pointer for immediate
      alias-mask flag!
- Line 2086
+ Line 2249
  Line 2086
  Line 2249
  : copy-execution-semantics ( ghost-from ghost-dest -- )
    >r
    dup >exec @ r@ >exec !
+   dup >comp @ r@ >comp !
    dup >exec2 @ r@ >exec2 !
    dup >exec-compile @ r@ >exec-compile !
    dup >ghost-xt @ r@ >ghost-xt !
- Line 2111
+ Line 2275
  Line 2111
  Line 2275
  Defer setup-prim-semantics
- : aprim   ( -- )
+ : mapprim   ( "forthname" "asmlabel" -- )
    THeader -1 aprim-nr +! aprim-nr @ T A, H
    asmprimname,
    setup-prim-semantics ;
- : aprim:   ( -- )
+ : mapprim:   ( "forthname" "asmlabel" -- )
    -1 aprim-nr +! aprim-nr @
-   Ghost tuck swap resolve <do:> swap tuck >magic !
+   Ghost tuck swap resolve-noforwards <do:> swap tuck >magic !
    asmprimname, ;
- : Alias:   ( cfa -- ) \ name
+ : Doer:   ( cfa -- ) \ name
    >in @ skip? IF  2drop  EXIT  THEN  >in !
    dup 0< s" prims" T $has? H 0= and
    IF
        .sourcepos ." needs doer: " >in @ bl word count type >in ! cr
    THEN
-   Ghost tuck swap resolve <do:> swap >magic ! ;
+   Ghost
+   tuck swap resolve-noforwards <do:> swap >magic ! ;
  Variable prim#
  : first-primitive ( n -- )  prim# ! ;
+ : group 0 word drop prim# @ 1- -$200 and prim# ! ;
+ : groupadd  ( n -- )  drop ;
  : Primitive  ( -- ) \ name
-   >in @ skip? IF  2drop  EXIT  THEN  >in !
+   >in @ skip? IF  drop  EXIT  THEN  >in !
-   dup 0< s" prims" T $has? H 0= and
+   s" prims" T $has? H 0=
    IF
       .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
    THEN
    prim# @ (THeader ( S xt ghost )
+   ['] prim-resolved over >comp !
    dup >ghost-flags <primitive> set-flag
-   over resolve T A, H alias-mask flag!
+   over resolve-noforwards T A, H alias-mask flag!
    -1 prim# +! ;
  >CROSS
- Line 2176
+ Line 2344
  Line 2176
  Line 2344
  \ compile                                              10may93jaw
  : compile  ( "name" -- ) \ name
- \  bl word gfind 0= ABORT" CROSS: Can't compile "
+   findghost
-   ghost
    dup >exec-compile @ ?dup
    IF    nip compile,
    ELSE  postpone literal postpone gexecute  THEN ;  immediate restrict
- Line 2199
+ Line 2366
  Line 2199
  Line 2366
  : [T']
  \ returns the target-cfa of a ghost, or compiles it as literal
-   postpone [G'] state @ IF postpone g>xt ELSE g>xt THEN ; immediate
+   postpone [G']
+   state @ IF postpone g>xt ELSE g>xt THEN ; immediate
  \ \ threading modell                                    13dec92py
  \ modularized                                           14jun97jaw
- Line 2219
+ Line 2387
  Line 2219
  Line 2387
  : (docol,)  ( -- ) [G'] :docol (doer,) ;                ' (docol,) plugin-of docol,
+                                                         ' NOOP plugin-of ca>native
  : (doprim,) ( -- )
    there xt>body + ca>native T a, H 1 fillcfa ;          ' (doprim,) plugin-of doprim,
  : (doeshandler,) ( -- )
-   T cfalign H compile :doesjump T 0 , H ;               ' (doeshandler,) plugin-of doeshandler,
+   T cfalign H [G'] :doesjump addr, T 0 , H ;            ' (doeshandler,) plugin-of doeshandler,
  : (dodoes,) ( does-action-ghost -- )
-   ]comp [G'] :dodoes gexecute comp[
+   ]comp [G'] :dodoes addr, comp[
    addr,
    \ the relocator in the c engine, does not like the
    \ does-address to marked for relocation
- Line 2257
+ Line 2427
  Line 2257
  Line 2427
  >TARGET
  : Code
    defempty?
-   (THeader there resolve
+   (THeader ( ghost )
+   ['] prim-resolved over >comp !
+   there resolve-noforwards
    [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]
    doprim,
    [THEN]
    depth (code) ;
+ \ FIXME : no-compile -1 ABORT" this ghost is not for compilation" ;
  : Code:
    defempty?
-     Ghost dup there ca>native resolve  <do:> swap >magic !
+     Ghost >r
+     r@ >ghostname there symentry
+     r@ there ca>native resolve-noforwards
+     <do:> r@ >magic !
+     r> drop
      depth (code) ;
  : end-code
- Line 2287
+ Line 2466
  Line 2287
  Line 2466
  : Char ( "<char>" -- )  bl word char+ c@ ;
  Cond: [Char]   ( "<char>" -- )  Char  lit, ;Cond
+ : (x#) ( adr len base -- )
+   base @ >r base ! 0 0 name >number 2drop drop r> base ! ;
+ : d# $0a (x#) ;
+ : h# $010 (x#) ;
+ Cond: d# $0a (x#) lit, ;Cond
+ Cond: h# $010 (x#) lit, ;Cond
  tchar 1 = [IF]
  Cond: chars ;Cond
  [THEN]
  \ some special literals                                 27jan97jaw
- \ !! Known Bug: Special Literals and plug-ins work only correct
- \ on 16 and 32 Bit Targets and 32 Bit Hosts!
- \ This section could be done with dlit, now. But first I need
- \ some test code JAW
  Cond: MAXU
-   tcell 1 cells u>
+   -1 s>d dlit,
-   IF    compile lit tcell 0 ?DO FF T c, H LOOP
-   ELSE  ffffffff lit, THEN
    ;Cond
+ tcell 2 = tcell 4 = or tcell 8 = or 0=
+ [IF]
+ .( Warning: MINI and MAXI may not work with this host) cr
+ [THEN]
  Cond: MINI
-   tcell 1 cells u>
+   tcell 2 = IF $8000 ELSE $80000000 THEN 0
-   IF    compile lit bigendian
+   tcell 8 = IF swap THEN dlit,
-         IF      80 T c, H tcell 1 ?DO 0 T c, H LOOP
-         ELSE    tcell 1 ?DO 0 T c, H LOOP 80 T c, H
-         THEN
-   ELSE  tcell 2 = IF 8000 ELSE 80000000 THEN lit, THEN
    ;Cond
  Cond: MAXI
-  tcell 1 cells u>
+   tcell 2 = IF $7fff ELSE $7fffffff THEN 0
-  IF     compile lit bigendian
+   tcell 8 = IF drop -1 swap THEN dlit,
-         IF      7F T c, H tcell 1 ?DO FF T c, H LOOP
-         ELSE    tcell 1 ?DO FF T c, H LOOP 7F T c, H
-         THEN
-  ELSE   tcell 2 = IF 7fff ELSE 7fffffff THEN lit, THEN
   ;Cond
  >CROSS
  \ Target compiling loop                                12dec92py
  \ ">tib trick thrown out                               10may93jaw
  \ number? defined at the top                           11may93jaw
- Line 2344
+ Line 2522
  Line 2344
  Line 2522
    IF    0> IF swap lit,  THEN  lit, discard
    ELSE  2drop restore-input throw Ghost gexecute THEN  ;
- >TARGET
  \ : ; DOES>                                            13dec92py
  \ ]                                                     9may93py/jaw
+ >CROSS
  : compiling-state ( -- )
  \G set states to compililng
      Compiling comp-state !
- Line 2362
+ Line 2541
  Line 2362
  Line 2541
     IF >ghost-xt @ execute X off ELSE drop THEN
     Interpreting comp-state ! ;
+ >TARGET
  : ]
      compiling-state
      BEGIN
- Line 2376
+ Line 2557
  Line 2376
  Line 2557
  \ by the way: defining a second interpreter (a compiler-)loop
  \             is not allowed if a system should be ans conform
+ : (:) ( ghost -- )
+ \ common factor of : and :noname. Prepare ;Resolve and start definition
+    ;Resolve ! there ;Resolve cell+ !
+    docol, ]comp  colon-start depth T ] H ;
  : : ( -- colon-sys ) \ Name
    defempty?
    constflag off \ don't let this flag work over colon defs
                  \ just to go sure nothing unwanted happens
    >in @ skip? IF  drop skip-defs  EXIT  THEN  >in !
-   (THeader ;Resolve ! there ;Resolve cell+ !
+   (THeader (:) ;
-    docol, ]comp  colon-start depth T ] H ;
  : :noname ( -- colon-sys )
-   X cfalign
+   X cfalign there
-   \ FIXME: cleanup!!!!!!!!
+   \ define a nameless ghost
-   \ idtentical to : with dummy ghost?!
+   here ghostheader dup last-header-ghost ! dup to lastghost
-   here ghostheader dup ;Resolve ! dup last-header-ghost ! to lastghost
+   (:) ;
-   there ;Resolve cell+ !
-   there docol, ]comp
-   colon-start depth T ] H ;
  Cond: EXIT ( -- )   compile ;S  ;Cond
- Line 2414
+ Line 2596
  Line 2414
  Line 2596
          fini,
          comp[
          ;Resolve @
-         IF      ;Resolve @ ;Resolve cell+ @ resolve
+         IF  ['] colon-resolved ;Resolve @ >comp !
-                 ['] colon-resolved ;Resolve @ >comp !
+             ;Resolve @ ;Resolve cell+ @ resolve
          THEN
          interpreting-state
          ;Cond
- Line 2424
+ Line 2606
  Line 2424
  Line 2606
  >CROSS
- Create GhostDummy ghostheader
+Value created
- <res> GhostDummy >magic !
  : !does ( does-action -- )
- \ !! zusammenziehen und dodoes, machen!
      tlastcfa @ [G'] :dovar killref
- \    tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
+     >space here >r ghostheader space>
- \ !! geht so nicht, da dodoes, ghost will!
+     ['] colon-resolved r@ >comp !
-     GhostDummy >link ! GhostDummy
+     r@ created >do:ghost ! r@ swap resolve
-     tlastcfa @ >tempdp dodoes, tempdp> ;
+     r> tlastcfa @ >tempdp dodoes, tempdp> ;
+ Defer instant-interpret-does>-hook  ' noop IS instant-interpret-does>-hook
- Defer instant-interpret-does>-hook
+ T has? peephole H [IF]
+ : does-resolved ( ghost -- )
+     compile does-exec g>xt T a, H ;
+ [ELSE]
+ : does-resolved ( ghost -- )
+     g>xt T a, H ;
+ [THEN]
  : resolve-does>-part ( -- )
  \ resolve words made by builders
    Last-Header-Ghost @ >do:ghost @ ?dup
-   IF    there resolve
+   IF  there resolve  THEN ;
-         \ TODO: set special DOES> resolver action here
-   THEN ;
  >TARGET
  Cond: DOES>
-         compile (does>) doeshandler,
+         T here 5 cells H + alit, compile (does>2) compile ;s
-         resolve-does>-part
+         doeshandler, resolve-does>-part
          ;Cond
- : DOES> switchrom doeshandler, T here H !does
+ : DOES>
+     ['] does-resolved created >comp !
+     switchrom doeshandler, T here H !does
    instant-interpret-does>-hook
    depth T ] H ;
- Line 2460
+ Line 2647
  Line 2460
  Line 2647
  \ Builder                                               11may93jaw
+Value built
  : Builder    ( Create-xt do-ghost "name" -- )
  \ builds up a builder in current vocabulary
  \ create-xt is executed when word is interpreted
  \ do:-xt is executed when the created word from builder is executed
  \ for do:-xt an additional entry after the normal ghost-entrys is used
-   Make-Ghost            ( Create-xt do-ghost ghost )
+   ghost to built
-   dup >created on
+   built >created @ 0= IF
-   rot swap              ( do-ghost Create-xt ghost )
+     built >created on
-   tuck >exec !
+   THEN ;
-   tuck >do:ghost !
-   ['] prim-resolved over >comp !
-   drop ;
  : gdoes,  ( ghost -- )
  \ makes the codefield for a word that is built
- Line 2492
+ Line 2678
  Line 2492
  Line 2678
  : takeover-x-semantics ( S constructor-ghost new-ghost -- )
  \g stores execution semantic and compilation semantic in the built word
- \g if the word already has a semantic (concerns S", IS, .", DOES>)
+    swap >do:ghost @ 2dup swap >do:ghost !
- \g then keep it
+    \ we use the >exec2 field for the semantic of a created word,
-    swap >do:ghost @
+    \ using exec or exec2 makes no difference for normal cross-compilation
-    \ we use the >exec2 field for the semantic of a crated word,
+    \ but is usefull for instant where the exec field is already
-    \ so predefined semantics e.g. for ....
+    \ defined (e.g. Vocabularies)
-    \ FIXME: find an example in the normal kernel!!!
 dup >exec @ swap >exec2 !
     >comp @ swap >comp ! ;
- \ old version of this:
- \  >exec dup @ ['] NoExec =
+Value createhere
- \  IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ;
+ : create-resolve ( -- )
+     created createhere resolve 0 ;Resolve ! ;
+ : create-resolve-immediate ( -- )
+     create-resolve T immediate H ;
  : TCreate ( <name> -- )
    create-forward-warn
    IF ['] reswarn-forward IS resolve-warning THEN
    executed-ghost @ (Theader
-   dup >created on
+   dup >created on  dup to created
-dup takeover-x-semantics hereresolve gdoes, ;
+dup takeover-x-semantics
+   there to createhere drop gdoes, ;
  : RTCreate ( <name> -- )
  \ creates a new word with code-field in ram
- Line 2517
+ Line 2707
  Line 2517
  Line 2707
    IF ['] reswarn-forward IS resolve-warning THEN
    \ make Alias
    executed-ghost @ (THeader
-   dup >created on
+   dup >created on  dup to created
 dup takeover-x-semantics
    there 0 T a, H alias-mask flag!
    \ store poiter to code-field
    switchram T cfalign H
    there swap T ! H
    there tlastcfa !
-   hereresolve gdoes, ;
+   there to createhere drop gdoes, ;
  : Build:  ( -- [xt] [colon-sys] )
    :noname postpone TCreate ;
- Line 2537
+ Line 2727
  Line 2537
  Line 2727
    postpone TCreate
    [ [THEN] ] ;
+ : ;Build
+   postpone create-resolve postpone ; built >exec ! ; immediate
+ : ;Build-immediate
+     postpone create-resolve-immediate
+     postpone ; built >exec ! ; immediate
  : gdoes>  ( ghost -- addr flag )
-   executed-ghost @
+   executed-ghost @ g>body ;
- \ FIXME: cleanup
- \  compiling? ABORT" CROSS: Executing gdoes> while compiling"
- \ ?! compiling? IF  gexecute true EXIT  THEN
-   g>body ( false ) ;
  \ DO: ;DO                                               11may93jaw
- \ changed to ?EXIT                                      10may93jaw
- : DO:     ( -- do-ghost [xt] [colon-sys] )
+ : do:ghost! ( ghost -- ) built >do:ghost ! ;
-   here ghostheader
+ : doexec! ( xt -- ) built >do:ghost @ >exec ! ;
-   :noname postpone gdoes> ( postpone ?EXIT ) ;
- : by:     ( -- do-ghost [xt] [colon-sys] ) \ name
+ : DO:     ( -- [xt] [colon-sys] )
-   Ghost
+   here ghostheader do:ghost!
-   :noname postpone gdoes> ( postpone ?EXIT ) ;
+   :noname postpone gdoes> ;
- : ;DO ( do-ghost [xt] [colon-sys] -- do-ghost )
+ : by:     ( -- [xt] [colon-sys] ) \ name
-   postpone ;    ( S addr xt )
+   Ghost do:ghost!
-   over >exec ! ; immediate
+   :noname postpone gdoes> ;
- : by      ( -- do-ghost ) \ Name
+ : ;DO ( [xt] [colon-sys] -- )
-   Ghost >do:ghost @ ;
+   postpone ; doexec! ; immediate
- : compile: ( do-ghost -- do-ghost [xt] [colon-sys] )
+ : by      ( -- ) \ Name
+   Ghost >do:ghost @ do:ghost! ;
+ : compile: ( --[xt] [colon-sys] )
  \G defines a compile time action for created words
  \G by this builder
    :noname ;
- : ;compile ( do-ghost [xt] [colon-sys] -- do-ghost )
+ : ;compile ( [xt] [colon-sys] -- )
-   postpone ;  over >comp ! ; immediate
+   postpone ; built >do:ghost @ >comp ! ; immediate
- >TARGET
  \ Variables and Constants                              05dec92py
- Build:  ( n -- ) ;
- by: :docon ( target-body-addr -- n ) T @ H ;DO
  Builder (Constant)
+ Build:  ( n -- ) ;Build
+ by: :docon ( target-body-addr -- n ) T @ H ;DO
- Build:  ( n -- ) T , H ;
- by (Constant)
  Builder Constant
+ Build:  ( n -- ) T , H ;Build
- Build:  ( n -- ) T A, H ;
  by (Constant)
  Builder AConstant
+ Build:  ( n -- ) T A, H ;Build
+ by (Constant)
- Build:  ( d -- ) T , , H ;
- DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
  Builder 2Constant
+ Build:  ( d -- ) T , , H ;Build
+ DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
- BuildSmart: ;
- by: :dovar ( target-body-addr -- addr ) ;DO
  Builder Create
+ BuildSmart: ;Build
+ by: :dovar ( target-body-addr -- addr ) ;DO
+ Builder Variable
  T has? rom H [IF]
- Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , H ( switchrom ) ;
+ Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , H ( switchrom ) ;Build
  by (Constant)
- Builder Variable
  [ELSE]
- Build: T 0 , H ;
+ Build: T 0 , H ;Build
  by Create
- Builder Variable
  [THEN]
+ Builder 2Variable
  T has? rom H [IF]
- Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;
+ Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;Build
  by (Constant)
- Builder 2Variable
  [ELSE]
- Build: T 0 , 0 , H ;
+ Build: T 0 , 0 , H ;Build
  by Create
- Builder 2Variable
  [THEN]
+ Builder AVariable
  T has? rom H [IF]
- Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 A, H ( switchrom ) ;
+ Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 A, H ( switchrom ) ;Build
  by (Constant)
- Builder AVariable
  [ELSE]
- Build: T 0 A, H ;
+ Build: T 0 A, H ;Build
  by Create
- Builder AVariable
  [THEN]
  \ User variables                                       04may94py
- >CROSS
+ : tup@ user-region >rstart @ ;
- Variable tup  0 tup !
+ \ Variable tup  0 tup !
- Variable tudp 0 tudp !
+ \ Variable tudp 0 tudp !
  : u,  ( n -- udp )
-   tup @ tudp @ + T  ! H
+   current-region >r user-region activate
-   tudp @ dup T cell+ H tudp ! ;
+   X here swap X , tup@ -
+   r> activate ;
  : au, ( n -- udp )
-   tup @ tudp @ + T A! H
+   current-region >r user-region activate
-   tudp @ dup T cell+ H tudp ! ;
+   X here swap X a, tup@ -
+   r> activate ;
- >TARGET
+ T has? no-userspace H [IF]
+ : buildby
+   ghost >exec @ built >exec ! ;
- Build: 0 u, X , ;
- by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO
  Builder User
+ buildby Variable
+ by Variable
- Build: 0 u, X , 0 u, drop ;
- by User
  Builder 2User
+ buildby 2Variable
+ by 2Variable
+ Builder AUser
+ buildby AVariable
+ by AVariable
+ [ELSE]
- Build: 0 au, X , ;
+ Builder User
+ Build: 0 u, X , ;Build
+ by: :douser ( ghost -- up-addr )  X @ tup@ + ;DO
+ Builder 2User
+ Build: 0 u, X , 0 u, drop ;Build
  by User
  Builder AUser
+ Build: 0 au, X , ;Build
+ by User
+ [THEN]
+ Builder (Value)
+ Build:  ( n -- ) ;Build
+ by: :docon ( target-body-addr -- n ) T @ H ;DO
- BuildSmart: T , H ;
- by (Constant)
  Builder Value
+ BuildSmart: T , H ;Build
+ by (Value)
- BuildSmart: T A, H ;
- by (Constant)
  Builder AValue
+ BuildSmart: T A, H ;Build
+ by (Value)
  Defer texecute
- BuildSmart:  ( -- ) [T'] noop T A, H ;
- by: :dodefer ( ghost -- ) X @ texecute ;DO
  Builder Defer
+ BuildSmart:  ( -- ) [T'] noop T A, H ;Build
+ by: :dodefer ( ghost -- ) X @ texecute ;DO
- Build: ( inter comp -- ) swap T immediate A, A, H ;
- DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
  Builder interpret/compile:
+ Build: ( inter comp -- ) swap T A, A, H ;Build-immediate
+ DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
  \ Sturctures                                           23feb95py
- >CROSS
  : nalign ( addr1 n -- addr2 )
  \ addr2 is the aligned version of addr1 wrt the alignment size n
 - tuck +  swap invert and ;
- >TARGET
- Build: ;
- by: :dofield T @ H + ;DO
  Builder (Field)
+ Build: ;Build
+ by: :dofield T @ H + ;DO
+ Builder Field
  Build: ( align1 offset1 align size "name" --  align2 offset2 )
      rot dup T , H ( align1 align size offset1 )
-     + >r nalign r> ;
+     + >r nalign r> ;Build
  by (Field)
- Builder Field
+ >TARGET
  : struct  T 1 chars 0 H ;
  : end-struct  T 2Constant H ;
  : cell% ( n -- size align )
      T 1 cells H dup ;
+ >CROSS
  \ Input-Methods                                            01py
- Build: ( m v -- m' v )  dup T , cell+ H ;
- DO:  abort" Not in cross mode" ;DO
  Builder input-method
+ Build: ( m v -- m' v )  dup T , cell+ H ;Build
- Build: ( m v size -- m v' )  over T , H + ;
  DO:  abort" Not in cross mode" ;DO
  Builder input-var
+ Build: ( m v size -- m v' )  over T , H + ;Build
+ DO:  abort" Not in cross mode" ;DO
+ \ Peephole optimization                                 05sep01jaw
+ \ this section defines different compilation
+ \ actions for created words
+ \ this will help the peephole optimizer
+ \ I (jaw) took this from bernds latest cross-compiler
+ \ changes but seperated it from the original
+ \ Builder words. The final plan is to put this
+ \ into a seperate file, together with the peephole
+ \ optimizer for cross
+ T has? peephole H [IF]
+ \ .( loading peephole optimization) cr
+ >CROSS
+ : (callc) compile call T >body a, H ;           ' (callc) plugin-of colon,
+ : (callcm) T here 0 a, 0 a, H ;                 ' (callcm) plugin-of colonmark,
+ : (call-res) >tempdp resolved gexecute tempdp> drop ;
+                                                 ' (call-res) plugin-of colon-resolve
+ : (pprim) dup 0< IF  $4000 -  ELSE
+     cr ." wrong usage of (prim) "
+     dup gdiscover IF  .ghost  ELSE  .  THEN  cr -1 throw  THEN
+     T a, H ;                                    ' (pprim) plugin-of prim,
+ \ if we want this, we have to spilt aconstant
+ \ and constant!!
+ \ Builder (Constant)
+ \ compile: g>body X @ lit, ;compile
+ Builder (Constant)
+ compile: g>body compile lit@ T a, H ;compile
+ Builder (Value)
+ compile: g>body compile lit@ T a, H ;compile
+ \ this changes also Variable, AVariable and 2Variable
+ Builder Create
+ compile: g>body alit, ;compile
+ Builder User
+ compile: g>body compile useraddr T @ , H ;compile
+ Builder Defer
+ compile: g>body compile lit-perform T A, H ;compile
+ Builder (Field)
+ compile: g>body T @ H compile lit+ T , H ;compile
+ Builder interpret/compile:
+ compile: does-resolved ;compile
+ Builder input-method
+ compile: does-resolved ;compile
+ Builder input-var
+ compile: does-resolved ;compile
+ [THEN]
  \ structural conditionals                              17dec92py
- Line 2725
+ Line 2998
  Line 2725
  Line 2998
  : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;
+ X has? abranch [IF]
+     : branchoffset ( src dest -- )  drop ;
+     : offset, ( n -- )  X A, ;
+ [ELSE]
  : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
+     : offset, ( n -- )  X , ;
+ [THEN]
- : >resolve    ( sys -- )
+ :noname compile branch X here branchoffset offset, ;
-         X here ( dup ." >" hex. ) over branchoffset swap X ! ;
- : <resolve    ( sys -- )
-         X here ( dup ." <" hex. ) branchoffset X , ;
- :noname compile branch X here branchoffset X , ;
    IS branch, ( target-addr -- )
- :noname compile ?branch X here branchoffset X , ;
+ :noname compile ?branch X here branchoffset offset, ;
    IS ?branch, ( target-addr -- )
- :noname compile branch T here 0 , H ;
+ :noname compile branch T here 0 H offset, ;
    IS branchmark, ( -- branchtoken )
- :noname compile ?branch T here 0 , H ;
+ :noname compile ?branch T here 0 H offset, ;
    IS ?branchmark, ( -- branchtoken )
- :noname T here 0 , H ;
+ :noname T here 0 H offset, ;
    IS ?domark, ( -- branchtoken )
  :noname dup X @ ?struc X here over branchoffset swap X ! ;
    IS branchtoresolve, ( branchtoken -- )
- Line 2759
+ Line 3032
  Line 2759
  Line 3032
  Variable tleavings 0 tleavings !
- : (done) ( addr -- )
+ : (done) ( do-addr -- )
+ \G resolve branches of leave and ?leave and ?do
+ \G do-addr is the address of the beginning of our
+ \G loop so we can take care of nested loops
      tleavings @
      BEGIN  dup
      WHILE
- Line 2809
+ Line 3085
  Line 2809
  Line 3085
 DO  dup @ swap 1 cells -  LOOP
      free throw ;
- : loop]     branchto, dup <resolve tcell - (done) ;
+ : loop] ( target-addr -- )
+   branchto,
+   dup   X here branchoffset offset,
+   tcell - (done) ;
  : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
- Line 2917
+ Line 3196
  Line 2917
  Line 3196
  : ,"            [char] " parse ht-string, X align ;
+ X has? control-rack [IF]
  Cond: ."        compile (.")     T ," H ;Cond
  Cond: S"        compile (S")     T ," H ;Cond
  Cond: C"        compile (C")     T ," H ;Cond
  Cond: ABORT"    compile (ABORT") T ," H ;Cond
+ [ELSE]
+ Cond: ."        '" parse tuck 2>r ahead, there 2r> ht-mem, X align
+                 >r then, r> compile ALiteral compile Literal compile type ;Cond
+ Cond: S"        '" parse tuck 2>r ahead, there 2r> ht-mem, X align
+                 >r then, r> compile ALiteral compile Literal ;Cond
+ Cond: C"        ahead, there [char] " parse ht-string, X align
+                 >r then, r> compile ALiteral ;Cond
+ Cond: ABORT"    if, ahead, there [char] " parse ht-string, X align
+                 >r then, r> compile ALiteral compile c(abort") then, ;Cond
+ [THEN]
  Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
  : IS            T >address ' >body ! H ;
- Line 2958
+ Line 3248
  Line 2958
  Line 3248
        ABORT" CROSS: Can't postpone on forward declaration"
        dup >magic @ <imm> =
        IF   (gexecute)
-       ELSE compile (compile) addr, THEN ;Cond
+       ELSE >link @ alit, compile compile,  THEN ;Cond
  \ save-cross                                           17mar93py
  hex
  >CROSS
- Create magic  s" Gforth2x" here over allot swap move
+ Create magic  s" Gforth3x" here over allot swap move
  bigendian 1+ \ strangely, in magic big=0, little=1
  tcell 1 = 0 and or
- Line 2981
+ Line 3271
  Line 2981
  Line 3271
  : save-cross ( "image-name" "binary-name" -- )
    bl parse ." Saving to " 2dup type cr
    w/o bin create-file throw >r
-   TNIL IF
+   s" header" X $has? IF
        s" #! "           r@ write-file throw
        bl parse          r@ write-file throw
        s"  --image-file" r@ write-file throw
- Line 2995
+ Line 3285
  Line 2995
  Line 3285
    ELSE
        bl parse 2drop
    THEN
-   image @ there
+   dictionary >rmem @ there
    r@ write-file throw \ write image
-   TNIL IF
+   s" relocate" X $has? IF
-       bit$  @ there 1- tcell>bit rshift 1+
+       dictionary >rbm @ there 1- tcell>bit rshift 1+
                  r@ write-file throw \ write tags
    THEN
    r> close-file throw ;
- Line 3008
+ Line 3298
  Line 3008
  Line 3298
    swap >image swap r@ write-file throw
    r> close-file throw ;
-[IF]
+ \ save-asm-region                                       29aug01jaw
  Variable name-ptr
  Create name-buf 200 chars allot
- Line 3062
+ Line 3352
  Line 3062
  Line 3352
    THEN
    @nb ;
+ \ FIXME why disabled?!
  : label-from-ghostnameXX ( ghost -- addr len )
  \ same as (label-from-ghostname) but caches generated names
    dup >asm-name @ ?dup IF nip count EXIT THEN
- Line 3153
+ Line 3444
  Line 3153
  Line 3444
    dup @ dup IF addr-refs @ THEN
    swap >r
    over align+ tuck tcell swap - rshift swap 0
-   DO dup 1 and
+   ?DO dup 1 and
       IF drop rdrop snl-calc UNLOOP EXIT THEN
 / swap 1+ swap
    LOOP
- Line 3215
+ Line 3506
  Line 3215
  Line 3506
  : save-asm-region ( region adr len -- )
    create-outfile (save-asm-region) close-outfile ;
- [THEN]
  \ \ minimal definitions
  >MINIMAL also minimal
- Line 3228
+ Line 3517
  Line 3228
  Line 3517
  \ \ [IF] [ELSE] [THEN] ...                              14sep97jaw
  \ it is useful to define our own structures and not to rely
- \ on the words in the compiler
+ \ on the words in the host system
- \ The words in the compiler might be defined with vocabularies
+ \ The words in the host system might be defined with vocabularies
  \ this doesn't work with our self-made compile-loop
  Create parsed 20 chars allot    \ store word we parsed
- Line 3242
+ Line 3531
  Line 3242
  Line 3531
 BEGIN
          BEGIN bl word count dup WHILE
              comment? 20 umin parsed place upcase parsed count
-dup s" [IF]" compare 0= >r
+dup s" [IF]" str= >r
-dup s" [IFUNDEF]" compare 0= >r
+dup s" [IFUNDEF]" str= >r
-dup s" [IFDEF]" compare 0= r> or r> or
+dup s" [IFDEF]" str= r> or r> or
              IF   2drop 1+
-             ELSE 2dup s" [ELSE]" compare 0=
+             ELSE 2dup s" [ELSE]" str=
                  IF   2drop 1- dup
                      IF 1+
                      THEN
                  ELSE
-dup s" [ENDIF]" compare 0= >r
+dup s" [ENDIF]" str= >r
-                     s" [THEN]" compare 0= r> or
+                     s" [THEN]" str= r> or
                      IF 1- THEN
                  THEN
              THEN
- Line 3300
+ Line 3589
  Line 3300
  Line 3589
       IF    >in ! X :
       ELSE drop
          BEGIN bl word dup c@
-               IF   count comment? s" ;" compare 0= ?EXIT
+               IF   count comment? s" ;" str= ?EXIT
                ELSE refill 0= ABORT" CROSS: Out of Input while C:"
                THEN
          AGAIN
- Line 3308
+ Line 3597
  Line 3308
  Line 3597
  : d? d? ;
+ : \D ( -- "debugswitch" )
  \G doesn't skip line when debug switch is on
- : \D D? 0= IF postpone \ THEN ;
+     D? 0= IF postpone \ THEN ;
+ : \- ( -- "wordname" )
  \G interprets the line if word is not defined
- : \- tdefined? IF postpone \ THEN ;
+    tdefined? IF postpone \ THEN ;
+ : \+ ( -- "wordname" )
  \G interprets the line if word is defined
- : \+ tdefined? 0= IF postpone \ THEN ;
+    tdefined? 0= IF postpone \ THEN ;
+ : \? ( -- "envorinstring" )
+ \G Skip line if environmental variable evaluates to false
+    X has? 0= IF postpone \ THEN ;
  Cond: \- \- ;Cond
  Cond: \+ \+ ;Cond
  Cond: \D \D ;Cond
+ Cond: \? \? ;Cond
  : ?? bl word find IF execute ELSE drop 0 THEN ;
- Line 3383
+ Line 3680
  Line 3383
  Line 3680
  : * * ;
  : / / ;
  : dup dup ;
+ : ?dup ?dup ;
  : over over ;
  : swap swap ;
  : rot rot ;
  : drop drop ;
+ : 2drop 2drop ;
  : =   = ;
+ : <>  <> ;
  : 0=   0= ;
  : lshift lshift ;
  : 2/ 2/ ;
+ : hex. base @ $10 base ! swap . base ! ;
+ : invert invert ;
  \ : . . ;
  : all-words    ['] forced?    IS skip? ;
- Line 3406
+ Line 3708
  Line 3406
  Line 3708
  : require require ;
  : needs require ;
  : .( [char] ) parse type ;
+ : ERROR" [char] " parse
+   rot
+   IF cr ." *** " type ."  ***" -1 ABORT" CROSS: Target error, see text above"
+   ELSE 2drop
+   THEN ;
  : ." [char] " parse type ;
  : cr cr ;
- Line 3425
+ Line 3732
  Line 3425
  Line 3732
  : doc-on        true  to-doc ! ;
  : declareunique ( "name" -- )
- \G Sets the unique flag for a ghost. The assembler output
+ \ Sets the unique flag for a ghost. The assembler output
- \G generates labels with the ghostname concatenated with the address
+ \ generates labels with the ghostname concatenated with the address
- \G while cross-compiling. The address is concatenated
+ \ while cross-compiling. The address is concatenated
- \G because we have double occurences of the same name.
+ \ because we have double occurences of the same name.
- \G If we want to reference the labels from the assembler or C
+ \ If we want to reference the labels from the assembler or C
- \G code we declare them unique, so the address is skipped.
+ \ code we declare them unique, so the address is skipped.
    Ghost >ghost-flags dup @ <unique> or swap ! ;
  \ [IFDEF] dbg : dbg dbg ; [THEN]
- Line 3442
+ Line 3749
  Line 3442
  Line 3749
  \ : words       also ghosts
  \                words previous ;
  : .s            .s ;
+ : depth         depth ;
  : bye           bye ;
  \ dummy
- : group 0 word drop ;
  \ turnkey direction
  : H forth ; immediate
- Line 3485
+ Line 3792
  Line 3485
  Line 3792
  [IFDEF] extend-cross extend-cross [THEN]
  LOCK

-Generate output suitable for use with a patch program
+Legend:



Removed from v.1.107
 


changed lines


 
Added in v.1.149
 Legend:



Removed from v.1.107
 


changed lines


 
Added in v.1.149
-Removed from v.1.107
+Added in v.1.149

CVS Admin

gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.107 and 1.149

ViewCVS and CVS Help