gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.114 and 1.129

-version 1.114, Wed Sep 12 14:55:54 2001 UTC
+version 1.129, Thu Sep 26 11:36:42 2002 UTC
  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 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 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 738
+ Line 767
  Line 738
  Line 767
  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 1007
+ Line 1041
  Line 1007
  Line 1041
  \ ' >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 1041
+ Line 1078
  Line 1041
  Line 1078
    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 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 1132
+ Line 1174
  Line 1132
  Line 1174
  false DefaultValue backtrace
  false DefaultValue new-input
  false DefaultValue peephole
+ false DefaultValue abranch
  [THEN]
  true DefaultValue interpreter
- Line 1194
+ Line 1237
  Line 1194
  Line 1237
  \ Variables                                            06oct92py
  Variable image
- Variable tlast    TNIL tlast !  \ Last name field
+ Variable (tlast)
+ (tlast) Value tlast TNIL tlast !  \ Last name field
  Variable tlastcfa \ Last code field
  Variable bit$
- Line 1218
+ Line 1262
  Line 1218
  Line 1262
  Variable mirrored-link          \ linked list for mirrored regions
 dup mirrored-link ! region-link !
+ : >rname 8 cells + ;
- : >rname 7 cells + ;
+ : >rbm   4 cells + ; \ bitfield per cell witch indicates relocation
- : >rbm   4 cells + ;
  : >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+ ;
- Line 1233
+ Line 1277
  Line 1233
  Line 1277
    >r r@ last-defined-region !
    r@ >rlen ! dup r@ >rstart ! r> >rdp ! ;
- : 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 1242
+ Line 1286
  Line 1242
  Line 1286
          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 , bl word count string,
    ELSE  \ store new parameters in region
          bl word drop
          >body (region)
- Line 1260
+ Line 1304
  Line 1260
  Line 1304
  \G returns the total area
    dup >rstart @ swap >rlen @ ;
- : mirrored
+ : mirrored ( -- )
- \G mark a region as 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 1392
+ Line 1440
  Line 1392
  Line 1440
  [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 1409
+ Line 1457
  Line 1409
  Line 1457
  : 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 1503
+ Line 1551
  Line 1503
  Line 1551
 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 1518
+ Line 1568
  Line 1518
  Line 1568
    \ 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 1566
+ Line 1628
  Line 1566
  Line 1628
  : (>image) ( taddr -- absaddr ) image @ + ;
  DEFER >image
+ DEFER >ramimage
  DEFER relon
  DEFER reloff
  DEFER correcter
- Line 1575
+ Line 1638
  Line 1575
  Line 1638
  ' (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 1598
+ Line 1672
  Line 1598
  Line 1672
      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 1619
+ Line 1693
  Line 1619
  Line 1693
  : 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 (compile)                 2drop
+ Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
+ Ghost (C")                                      drop
+ Ghost '                                         drop
+ \ user ghosts
+ Ghost state drop
  \ \ --------------------        Host/Target copy etc.           29aug01jaw
- Line 1679
+ Line 1769
  Line 1679
  Line 1769
  : (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 1690
+ Line 1780
  Line 1690
  Line 1780
          tempdp> ;                               ' (dr) plugin-of doer-resolve
  : (cm) ( -- addr )
-     T here align H
+     there -1 colon, ;                           ' (cm) plugin-of colonmark,
-     -1 prim, ;                                  ' (cm) plugin-of colonmark,
  >TARGET
  : compile, ( xt -- )
- Line 1776
+ Line 1865
  Line 1776
  Line 1865
    >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 used currently
- : 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
- Line 1825
+ Line 1944
  Line 1825
  Line 1944
    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 -- )
- Line 1947
+ Line 2066
  Line 1947
  Line 2066
  \ 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-end 2 c,  bl 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 1965
+ Line 2086
  Line 1965
  Line 2086
          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 1979
+ Line 2100
  Line 1979
  Line 2100
          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 2060
+ Line 2197
  Line 2060
  Line 2197
  \    >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 2087
+ Line 2220
  Line 2087
  Line 2220
  : 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 2119
+ Line 2253
  Line 2119
  Line 2253
  : 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# ! ;
  : 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 2177
+ Line 2313
  Line 2177
  Line 2313
  \ 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 2200
+ Line 2335
  Line 2200
  Line 2335
  : [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 2220
+ Line 2356
  Line 2220
  Line 2356
  : (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 2258
+ Line 2396
  Line 2258
  Line 2396
  >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 2294
+ Line 2441
  Line 2294
  Line 2441
  \ 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 2345
+ Line 2482
  Line 2345
  Line 2482
    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 2363
+ Line 2501
  Line 2363
  Line 2501
     IF >ghost-xt @ execute X off ELSE drop THEN
     Interpreting comp-state ! ;
+ >TARGET
  : ]
      compiling-state
      BEGIN
- Line 2416
+ Line 2556
  Line 2416
  Line 2556
          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 2426
+ Line 2566
  Line 2426
  Line 2566
  >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
+ : does-resolved ( ghost -- )
+     compile does-exec g>xt T a, H ;
  : 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>
- Line 2453
+ Line 2591
  Line 2453
  Line 2591
          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 2473
+ Line 2613
  Line 2473
  Line 2613
    ghost to built
    built >created @ 0= IF
      built >created on
-     ['] prim-resolved built >comp !
    THEN ;
  : gdoes,  ( ghost -- )
- Line 2494
+ Line 2633
  Line 2494
  Line 2633
  : takeover-x-semantics ( S constructor-ghost new-ghost -- )
  \g stores execution semantic and compilation semantic in the built word
-    swap >do:ghost @
+    swap >do:ghost @ 2dup swap >do:ghost !
     \ we use the >exec2 field for the semantic of a created word,
     \ using exec or exec2 makes no difference for normal cross-compilation
     \ but is usefull for instant where the exec field is already
- Line 2502
+ Line 2641
  Line 2502
  Line 2641
 dup >exec @ swap >exec2 !
     >comp @ swap >comp ! ;
+Value createhere
+ : 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 2515
+ Line 2662
  Line 2515
  Line 2662
    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 2536
+ Line 2683
  Line 2536
  Line 2683
    [ [THEN] ] ;
  : ;Build
+   postpone create-resolve postpone ; built >exec ! ; immediate
+ : ;Build-immediate
+     postpone create-resolve-immediate
    postpone ; built >exec ! ; immediate
  : gdoes>  ( ghost -- addr flag )
- Line 2661
+ Line 2812
  Line 2661
  Line 2812
  by: :dodefer ( ghost -- ) X @ texecute ;DO
  Builder interpret/compile:
- Build: ( inter comp -- ) swap T immediate A, A, H ;Build
+ Build: ( inter comp -- ) swap T A, A, H ;Build-immediate
  DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
  \ Sturctures                                           23feb95py
- Line 2704
+ Line 2855
  Line 2704
  Line 2855
  \ this section defines different compilation
  \ actions for created words
  \ this will help the peephole optimizer
- \ I (jaw) took this from bernds lates cross-compiler
+ \ 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
- Line 2714
+ Line 2865
  Line 2714
  Line 2865
  T has? peephole H [IF]
  >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!!
- Line 2722
+ Line 2881
  Line 2722
  Line 2881
  \ compile: g>body X @ lit, ;compile
  Builder (Constant)
- compile: g>body alit, compile @ ;compile
+ compile: g>body compile lit@ T a, H ;compile
  Builder (Value)
- compile: g>body alit, compile @ ;compile
+ compile: g>body compile lit@ T a, H ;compile
  \ this changes also Variable, AVariable and 2Variable
  Builder Create
- \ compile: g>body alit, ;compile
+ compile: g>body alit, ;compile
  Builder User
  compile: g>body compile useraddr T @ , H ;compile
  Builder Defer
- compile: g>body alit, compile @ compile execute ;compile
+ compile: g>body compile lit-perform T A, H ;compile
  Builder (Field)
- compile: g>body T @ H lit, compile + ;compile
+ 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]
- Line 2760
+ Line 2928
  Line 2760
  Line 2928
  : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
- : >resolve    ( sys -- )
-         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 , ;
- Line 2792
+ Line 2954
  Line 2792
  Line 2954
  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 2842
+ Line 3007
  Line 2842
  Line 3007
 DO  dup @ swap 1 cells -  LOOP
      free throw ;
- : loop]     branchto, dup <resolve tcell - (done) ;
+ : loop] ( target-addr -- )
+   branchto,
+   dup   X here branchoffset X ,
+   tcell - (done) ;
  : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
- Line 2946
+ Line 3114
  Line 2946
  Line 3114
  Cond: +LOOP     1 ncontrols? +loop, ;Cond
  Cond: NEXT      1 ncontrols? next, ;Cond
+ \ Absoulte branches                                     26sep02jaw
+ \ This section defined different semantics for
+ \ conditionals, using and compiling absolute branches
+ X has? abranch [IF]
+ Ghost abranch drop
+ Ghost a?branch drop
+ Ghost a(?do) drop
+ Ghost a(do) drop
+ Ghost a(next) drop
+ Ghost a(+loop) drop
+ Ghost a(loop) drop
+ :noname compile abranch X a, ;             plugin-of branch,
+ :noname compile a?branch X a, ;            plugin-of ?branch,
+ :noname compile abranch T here 0  a, H ;   plugin-of branchmark,
+ :noname compile a?branch T here 0 a, H ;   plugin-of ?branchmark,
+ :noname
+   dup X @ ABORT" CROSS: branch already resolved"
+   X here swap X a! ;                       plugin-of branchtoresolve,
+ :noname
+compile a(?do) ?domark, (leave)
+   branchtomark, 2 to1 ;                    plugin-of ?do,
+ : aloop] ( target-addr -- )
+   branchto,
+   dup X a,
+   tcell - (done) ;
+ :noname
+to compile a(loop) aloop]
+   compile unloop skiploop] ;               plugin-of loop,
+ :noname
+to compile a(+loop) aloop]
+   compile unloop skiploop] ;               plugin-of +loop,
+ :noname
+   compile a(next) aloop] compile unloop ;   plugin-of next,
+ [THEN]
  \ String words                                         23feb93py
  : ,"            [char] " parse ht-string, X align ;
- Line 3187
+ Line 3404
  Line 3187
  Line 3404
    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 3274
+ Line 3491
  Line 3274
  Line 3491
 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 3332
+ Line 3549
  Line 3332
  Line 3549
       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 3340
+ Line 3557
  Line 3340
  Line 3557
  : 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 3420
+ Line 3645
  Line 3420
  Line 3645
  : rot rot ;
  : drop drop ;
  : =   = ;
+ : <>  <> ;
  : 0=   0= ;
  : lshift lshift ;
  : 2/ 2/ ;
- Line 3457
+ Line 3683
  Line 3457
  Line 3683
  : 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 3474
+ Line 3700
  Line 3474
  Line 3700
  \ : words       also ghosts
  \                words previous ;
  : .s            .s ;
+ : depth         depth ;
  : bye           bye ;
  \ dummy

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



Removed from v.1.114
 


changed lines


 
Added in v.1.129
 Legend:



Removed from v.1.114
 


changed lines


 
Added in v.1.129
-Removed from v.1.114
+Added in v.1.129

CVS Admin

gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.114 and 1.129

ViewCVS and CVS Help