### Diff for /gforth/cross.fs between versions 1.114 and 1.124

version 1.114, 2001/09/12 14:55:54 version 1.124, 2002/03/21 17:11:10
Line 71  H Line 71  H

>CROSS  >CROSS

\ Test against this definitions to find out whether we are cross-compiling
\ may be usefull for assemblers
0 Constant gforth-cross-indicator

\ find out whether we are compiling with gforth  \ find out whether we are compiling with gforth

: defined? bl word find nip ;  : defined? bl word find nip ;
Line 202  Create bases   10 ,   2 ,   A , 100 , Line 206  Create bases   10 ,   2 ,   A , 100 ,

[THEN]  [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 !!  hex     \ the defualt base for the cross-compiler is hex !!
\ Warnings off  \ Warnings off

Line 242  hex     \ the defualt base for the cross Line 253  hex     \ the defualt base for the cross

hex  hex

\ FIXME delete`
\ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are  \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are
\ for cross-compiling                          \ for cross-compiling
\ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!  \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!

\ FIXME move down
2dup s" (" compare 0=          2dup s" (" compare 0=
IF    postpone (          IF    postpone (
ELSE  2dup s" \" compare 0= IF postpone \ THEN          ELSE  2dup s" \" compare 0= IF postpone \ THEN
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
ELSE    -1 ABORT" Cross: access method not supported!"  \G switch to target dictionary. Used as prefix e.g. for @, !, here etc.
THEN ; immediate    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

\ Begin CROSS COMPILER:  \ Begin CROSS COMPILER:

Line 303  set-order previous Line 319  set-order previous
\ POSTPONE false           \ POSTPONE false
THEN ; immediate    THEN ; immediate

\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] ]
2drop drop
[ [THEN] ] ;

\ \ --------------------        source file  \ \ --------------------        source file

decimal  decimal
Line 738  Plugin next, ( for-token ) Line 766  Plugin next, ( for-token )
Plugin leave,   ( -- )  Plugin leave,   ( -- )
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
\ 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

Plugin doprim,  \ compiles start of a primitive  Plugin doprim,  \ compiles start of a primitive
Plugin docol,           \ compiles start of a colon definition  Plugin docol,           \ compiles start of a colon definition
Line 893  Variable cross-space-dp-orig Line 926  Variable cross-space-dp-orig
Defer is-forward  Defer is-forward

ghost-list linked <fwd> , 0 , ['] NoExec , ['] is-forward ,       ghost-list linked <fwd> , 0 , ['] NoExec , ['] is-forward ,
0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;

Line 1007  Variable reuse-ghosts reuse-ghosts off Line 1040  Variable reuse-ghosts reuse-ghosts off

\ ' >ghostname ALIAS @name  \ ' >ghostname ALIAS @name

: findghost ( "ghostname" -- ghost )
bl word gfind 0= ABORT" CROSS: Ghost don't exists" ;

: [G'] ( -- ghost : name )  : [G'] ( -- ghost : name )
\G ticks a ghost and returns its address  \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>xt ( ghost -- xt )
\G Returns the xt (cfa) of a ghost. Issues a warning if undefined.  \G Returns the xt (cfa) of a ghost. Issues a warning if undefined.
dup @ ?dup IF nip EXIT THEN    dup @ ?dup IF nip EXIT THEN
addr-struct %allocerase tuck swap ! ;    addr-struct %allocerase tuck swap ! ;

>cross

\ Predefined ghosts                                    12dec92py  \ Predefined ghosts                                    12dec92py

Ghost - drop \ need a ghost otherwise "-" would be treated as a number  Ghost - drop \ need a ghost otherwise "-" would be treated as a number

Ghost 0=                                        drop  Ghost 0=                                        drop
Ghost branch    Ghost ?branch                   2drop  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 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 over      Ghost =         Ghost drop      2drop drop
Ghost 2drop drop  Ghost 2drop drop
Ghost 2dup drop  Ghost 2dup drop
Ghost call drop
Ghost @ 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  \ \ Parameter for target systems                         06oct92py

>cross
\ we define it ans like...  \ we define it ans like...
wordlist Constant target-environment  wordlist Constant target-environment

Line 1194  tbits/char bits/byte / Constant tbyte Line 1235  tbits/char bits/byte / Constant tbyte
\ Variables                                            06oct92py  \ Variables                                            06oct92py

Variable image  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 tlastcfa \ Last code field
Variable bit\$  Variable bit\$

: >rname 8 cells + ;
: >rname 7 cells + ;  : >rbm   4 cells + ; \ bitfield per cell witch indicates relocation
: >rbm   4 cells + ;
: >rmem  5 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 + ;  : >rlink 3 cells + ;
: >rdp 2 cells + ;  : >rdp 2 cells + ;
: >rlen cell+ ;  : >rlen cell+ ;
>r r@ last-defined-region !    >r r@ last-defined-region !
r@ >rlen ! dup r@ >rstart ! r> >rdp ! ;    r@ >rlen ! dup r@ >rstart ! r> >rdp ! ;

: region ( addr len -- )                  : region ( addr len -- "name" )
\G create a new region  \G create a new region
\ check whether predefined region exists     \ check whether predefined region exists
save-input bl word find >r >r restore-input throw r> r> 0=     save-input bl word find >r >r restore-input throw r> r> 0=
save-input create restore-input throw          save-input create restore-input throw
here last-defined-region !          here last-defined-region !
over ( startaddr ) , ( length ) , ( dp ) ,          over ( startaddr ) , ( length ) , ( dp ) ,
region-link linked 0 , 0 , 0 , bl word count string,          region-link linked 0 , 0 , 0 , 0 , bl word count string,
ELSE  \ store new parameters in region    ELSE  \ store new parameters in region
bl word drop          bl word drop
>body (region)          >body (region)
\G returns the total area  \G returns the total area
dup >rstart @ swap >rlen @ ;    dup >rstart @ swap >rlen @ ;

: mirrored                                : mirrored ( -- )
\G mark a region as mirrored  \G mark last defined region as mirrored
align linked last-defined-region @ , ;    align linked last-defined-region @ , ;

: writeprotected
\G mark a region as write protected
-1 last-defined-region @ >rrom ! ;

: .addr ( u -- )  : .addr ( u -- )
\G prints a 16 or 32 Bit nice hex value  \G prints a 16 or 32 Bit nice hex value
base @ >r hex    base @ >r hex
Line 1392  variable sromdp  \ start of rom-area for Line 1438  variable sromdp  \ start of rom-area for

[THEN]  [THEN]

0 Value current-region
0 value tdp  0 Value tdp
variable fixed          \ flag: true: no automatic switching  Variable fixed          \ flag: true: no automatic switching
\       false: switching is done automatically                          \       false: switching is done automatically

\ Switch-Policy:  \ Switch-Policy:
Line 1409  variable constflag constflag off Line 1455  variable constflag constflag off

: activate ( region -- )  : activate ( region -- )
\G next code goes to this region  \G next code goes to this region
>rdp to tdp ;    dup to current-region >rdp to tdp ;

: (switchram)  : (switchram)
fixed @ ?EXIT s" rom" T \$has? H 0= ?EXIT    fixed @ ?EXIT s" rom" T \$has? H 0= ?EXIT
Line 1503  bigendian Line 1549  bigendian
2drop 0 ;    2drop 0 ;

-1 ABORT" Address out of range!"          -1 ABORT" Address out of range!"
Line 1518  bigendian Line 1566  bigendian
r> >rmem @ + ;    r> >rmem @ + ;

\G same as (>regionimage) but aborts if the region is rom
dup
\ find region we want to address
>r
r@ >rrom @ ABORT" CROSS: region is write-protected!"
\ calculate offset in region
r@ >rstart @ -
r> >rmem @ + ;

dup    dup
\ find region we want to address    \ find region we want to address
Line 1566  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 1626  CREATE Bittable 80 c, 40 c, 20 c, 10 c,

DEFER >image  DEFER >image
DEFER >ramimage
DEFER relon  DEFER relon
DEFER reloff  DEFER reloff
DEFER correcter  DEFER correcter
Line 1575  T has? relocate H Line 1636  T has? relocate H
' (relon) IS relon  ' (relon) IS relon
' (reloff) IS reloff  ' (reloff) IS reloff
' (>regionimage) IS >image  ' (>regionimage) IS >image
' (>regionimage) IS >ramimage
[ELSE]  [ELSE]
' drop IS relon  ' drop IS relon
' drop IS reloff  ' drop IS reloff
' (>regionimage) IS >image  ' (>regionimage) IS >image
' (>regionimage) IS >ramimage
[THEN]  [THEN]

: enforce-writeprotection ( -- )
['] (>regionramimage) IS >ramimage ;

: relax-writeprotection ( -- )
['] (>regionimage) IS >ramimage ;

: writeprotection-relaxed? ( -- )
['] >ramimage >body @ ['] (>regionimage) = ;

\ Target memory access                                 06oct92py  \ Target memory access                                 06oct92py

: align+  ( taddr -- rest )  : align+  ( taddr -- rest )
Line 1598  T has? relocate H Line 1670  T has? relocate H
dup cfalign+ + ;      dup cfalign+ + ;

: @  ( taddr -- w )     >image S@ ;  : @  ( taddr -- w )     >image S@ ;
: !  ( w taddr -- )     >image S! ;  : !  ( w taddr -- )     >ramimage S! ;
: c@ ( taddr -- char )  >image Sc@ ;  : 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@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
: 2! ( x1 x2 taddr -- ) T tuck ! cell+ ! H ;  : 2! ( x1 x2 taddr -- ) T tuck ! cell+ ! H ;

Line 1619  T has? relocate H Line 1691  T has? relocate H
: A!                    swap >address swap dup relon T ! H ;  : A!                    swap >address swap dup relon T ! H ;
: A,    ( w -- )        >address T here H relon T , H ;  : A,    ( w -- )        >address T here H relon T , H ;

\ 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  \ \ --------------------        Host/Target copy etc.           29aug01jaw

Line 1679  previous Line 1767  previous
: (cc) T a, H ;                                 ' (cc) plugin-of colon,  : (cc) T a, H ;                                 ' (cc) plugin-of colon,
: (prim) T a, H ;                               ' (prim) plugin-of prim,  : (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  : (ar) T ! H ;                                  ' (ar) plugin-of addr-resolve
>tempdp drop over           >tempdp drop over
Line 1690  previous Line 1778  previous
tempdp> ;                               ' (dr) plugin-of doer-resolve          tempdp> ;                               ' (dr) plugin-of doer-resolve

: (cm) ( -- addr )  : (cm) ( -- addr )
T here align H      there -1 colon, ;                           ' (cm) plugin-of colonmark,
-1 prim, ;                                  ' (cm) plugin-of colonmark,

>TARGET  >TARGET
: compile, ( xt -- )  : compile, ( xt -- )
Line 1717  previous Line 1804  previous
sourceline# ,       sourceline# ,
space>      space>
;  ;

: refered ( ghost tag -- )  : refered ( ghost tag -- )
\G creates a resolve structure  \G creates a resolve structure
Line 1776  Defer resolve-warning Line 1863  Defer resolve-warning

: colon-resolved   ( ghost -- )  : colon-resolved   ( ghost -- )
>link @ colon, ; \ compile-call  \ compiles a call to a colon definition,
\ compile action for >comp field

: prim-resolved  ( ghost -- )  : prim-resolved  ( ghost -- )
\ compiles a call to a primitive

\ FIXME: not used currently
: does-resolved ( ghost -- )
dup g>body alit, >do:ghost @ g>body colon, ;

: (is-forward)   ( ghost -- )  : (is-forward)   ( ghost -- )
colonmark, 0 (refered) ; \ compile space for call      colonmark, 0 (refered) ; \ compile space for call
' (is-forward) IS is-forward  ' (is-forward) IS is-forward

: resolve  ( ghost tcfa -- )  0 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 !
r> comp-state !

['] noop IS resolve-warning ;

: (resolve) ( ghost tcfa -- ghost resolve-list )
\ check for a valid address, it is a primitive reference
\ otherwise

\ we define new address only if empty        \ we define new address only if empty
\ this is for not to take over the alias ghost        \ this is for not to take over the alias ghost
\ (different ghost, but identical xt)        \ (different ghost, but identical xt)
\ but the very first that really defines it        \ but the very first that really defines it
dup @ 0= IF ! ELSE 2drop THEN        dup @ 0= IF ! ELSE 2drop THEN
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       \ is ghost resolved?, second resolve means another
\ definition with the same name      \ definition with the same name
over undefined? 0= IF  exists EXIT THEN      over undefined? 0= IF  exists EXIT THEN
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  \ gexecute ghost,                                      01nov92py

Line 1825  Defer resolve-warning Line 1942  Defer resolve-warning
dup >comp @ EXECUTE ;    dup >comp @ EXECUTE ;

: gexecute ( ghost -- )  : gexecute ( ghost -- )
dup >magic @ <imm> = IF -1 ABORT" CROSS: gexecute on immediate word" THEN    dup >magic @ <imm> = ABORT" CROSS: gexecute on immediate word"
(gexecute) ;    (gexecute) ;

: addr,  ( ghost -- )  : addr,  ( ghost -- )
Line 1947  Variable to-doc  to-doc on Line 2064  Variable to-doc  to-doc on
\ Target TAGS creation  \ Target TAGS creation

s" kernel.TAGS" r/w create-file throw value tag-file-id  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  \ contains the file-id of the tags file

Create tag-beg 2 c,  7F c, bl c,  Create tag-beg 2 c,  7F c, bl c,
Create tag-end 2 c,  bl c, 01 c,  Create tag-end 2 c,  bl c, 01 c,
Create tag-bof 1 c,  0C c,  Create tag-bof 1 c,  0C c,
Create tag-tab 1 c,  09 c,

Line 1965  Create tag-bof 1 c,  0C c, Line 2084  Create tag-bof 1 c,  0C c,
s" ,0" tag-file-id write-line throw          s" ,0" tag-file-id write-line throw
THEN ;      THEN ;

: cross-tag-entry  ( -- )  : cross-gnu-tag-entry  ( -- )
tlast @ 0<> \ not an anonymous (i.e. noname) header      tlast @ 0<> \ not an anonymous (i.e. noname) header
IF      IF
source >in @ min tag-file-id write-file throw          source >in @ min tag-file-id write-file throw
tag-beg count 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          tag-end count tag-file-id write-file throw
base @ decimal sourceline# 0 <# #s #> 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  \       >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
Line 1979  Create tag-bof 1 c,  0C c, Line 2098  Create tag-bof 1 c,  0C c,
base !          base !
THEN ;      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  \ Check for words

Defer skip? ' false IS skip?  Defer skip? ' false IS skip?
Line 2060  Defer setup-execution-semantics Line 2195  Defer setup-execution-semantics
\    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !  \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !
\ output symbol table to extra file      \ 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 Last-Header-Ghost ! dup to lastghost
dup >magic ^imm !     \ a pointer for immediate      dup >magic ^imm !     \ a pointer for immediate
Line 2087  Variable aprim-nr -20 aprim-nr ! Line 2218  Variable aprim-nr -20 aprim-nr !
: copy-execution-semantics ( ghost-from ghost-dest -- )  : copy-execution-semantics ( ghost-from ghost-dest -- )
>r    >r
dup >exec @ r@ >exec !    dup >exec @ r@ >exec !
dup >comp @ r@ >comp !
dup >exec2 @ r@ >exec2 !    dup >exec2 @ r@ >exec2 !
dup >exec-compile @ r@ >exec-compile !    dup >exec-compile @ r@ >exec-compile !
dup >ghost-xt @ r@ >ghost-xt !    dup >ghost-xt @ r@ >ghost-xt !
Line 2119  Defer setup-prim-semantics Line 2251  Defer setup-prim-semantics

: mapprim:   ( "forthname" "asmlabel" -- )   : mapprim:   ( "forthname" "asmlabel" -- )
-1 aprim-nr +! aprim-nr @    -1 aprim-nr +! aprim-nr @
Ghost tuck swap resolve <do:> swap tuck >magic !    Ghost tuck swap resolve-noforwards <do:> swap tuck >magic !
asmprimname, ;    asmprimname, ;

: Alias:   ( cfa -- ) \ name  : Doer:   ( cfa -- ) \ name
>in @ skip? IF  2drop  EXIT  THEN  >in !    >in @ skip? IF  2drop  EXIT  THEN  >in !
dup 0< s" prims" T \$has? H 0= and    dup 0< s" prims" T \$has? H 0= and
IF    IF
.sourcepos ." needs doer: " >in @ bl word count type >in ! cr        .sourcepos ." needs doer: " >in @ bl word count type >in ! cr
THEN    THEN
Ghost tuck swap resolve <do:> swap >magic ! ;    Ghost
tuck swap resolve-noforwards <do:> swap >magic ! ;

Variable prim#  Variable prim#
: first-primitive ( n -- )  prim# ! ;  : first-primitive ( n -- )  prim# ! ;
: Primitive  ( -- ) \ name  : 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    IF
.sourcepos ." needs prim: " >in @ bl word count type >in ! cr       .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
THEN    THEN
prim# @ (THeader ( S xt ghost )    prim# @ (THeader ( S xt ghost )
['] prim-resolved over >comp !
dup >ghost-flags <primitive> set-flag    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# +! ;    -1 prim# +! ;
>CROSS  >CROSS

Line 2177  Comment (       Comment \ Line 2311  Comment (       Comment \
\ compile                                              10may93jaw  \ compile                                              10may93jaw

: compile  ( "name" -- ) \ name  : compile  ( "name" -- ) \ name
\  bl word gfind 0= ABORT" CROSS: Can't compile "    findghost
ghost
dup >exec-compile @ ?dup    dup >exec-compile @ ?dup
IF    nip compile,    IF    nip compile,
ELSE  postpone literal postpone gexecute  THEN ;  immediate restrict    ELSE  postpone literal postpone gexecute  THEN ;  immediate restrict
Line 2200  Cond: [']  T ' H alit, ;Cond Line 2333  Cond: [']  T ' H alit, ;Cond

: [T']  : [T']
\ returns the target-cfa of a ghost, or compiles it as literal  \ 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

\ modularized                                           14jun97jaw  \ modularized                                           14jun97jaw
Line 2220  T 2 cells H Value xt>body Line 2354  T 2 cells H Value xt>body

: (docol,)  ( -- ) [G'] :docol (doer,) ;                ' (docol,) plugin-of docol,  : (docol,)  ( -- ) [G'] :docol (doer,) ;                ' (docol,) plugin-of docol,

' NOOP plugin-of ca>native

: (doprim,) ( -- )  : (doprim,) ( -- )
there xt>body + ca>native T a, H 1 fillcfa ;          ' (doprim,) plugin-of doprim,    there xt>body + ca>native T a, H 1 fillcfa ;          ' (doprim,) plugin-of doprim,

: (doeshandler,) ( -- )   : (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 -- )  : (dodoes,) ( does-action-ghost -- )
]comp [G'] :dodoes gexecute comp[    ]comp [G'] :dodoes addr, comp[
\ the relocator in the c engine, does not like the    \ the relocator in the c engine, does not like the
\ does-address to marked for relocation    \ does-address to marked for relocation
Line 2258  Defer (end-code) Line 2394  Defer (end-code)
>TARGET  >TARGET
: Code  : Code
defempty?    defempty?
['] prim-resolved over >comp !
there resolve-noforwards

[ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]    [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]
doprim,     doprim,
[THEN]    [THEN]
depth (code) ;    depth (code) ;

\ FIXME : no-compile -1 ABORT" this ghost is not for compilation" ;

: Code:  : Code:
defempty?    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) ;      depth (code) ;

: end-code  : end-code
Line 2325  Cond: MAXI Line 2470  Cond: MAXI
;Cond   ;Cond

>CROSS  >CROSS

\ Target compiling loop                                12dec92py  \ Target compiling loop                                12dec92py
\ ">tib trick thrown out                               10may93jaw  \ ">tib trick thrown out                               10may93jaw
\ number? defined at the top                           11may93jaw  \ number? defined at the top                           11may93jaw
Line 2345  Cond: MAXI Line 2491  Cond: MAXI
IF    0> IF swap lit,  THEN  lit, discard    IF    0> IF swap lit,  THEN  lit, discard
ELSE  2drop restore-input throw Ghost gexecute THEN  ;    ELSE  2drop restore-input throw Ghost gexecute THEN  ;

>TARGET
\ : ; DOES>                                            13dec92py  \ : ; DOES>                                            13dec92py
\ ]                                                     9may93py/jaw  \ ]                                                     9may93py/jaw

>CROSS

: compiling-state ( -- )  : compiling-state ( -- )
\G set states to compililng  \G set states to compililng
Compiling comp-state !      Compiling comp-state !
Line 2363  Cond: MAXI Line 2510  Cond: MAXI
IF >ghost-xt @ execute X off ELSE drop THEN     IF >ghost-xt @ execute X off ELSE drop THEN
Interpreting comp-state ! ;     Interpreting comp-state ! ;

>TARGET

: ]   : ]
compiling-state      compiling-state
BEGIN      BEGIN
Line 2416  Cond: ; ( -- ) Line 2565  Cond: ; ( -- )
fini,          fini,
comp[          comp[
;Resolve @           ;Resolve @
IF      ;Resolve @ ;Resolve cell+ @ resolve           IF  ['] colon-resolved ;Resolve @ >comp !
['] colon-resolved ;Resolve @ >comp !              ;Resolve @ ;Resolve cell+ @ resolve
THEN          THEN
interpreting-state          interpreting-state
;Cond          ;Cond
Line 2426  Cond: [ ( -- ) interpreting-state ;Cond Line 2575  Cond: [ ( -- ) interpreting-state ;Cond

>CROSS  >CROSS

Create GhostDummy ghostheader  0 Value created
<res> GhostDummy >magic !

: !does ( does-action -- )  : !does ( does-action -- )
\ !! zusammenziehen und dodoes, machen!
tlastcfa @ [G'] :dovar killref      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  Defer instant-interpret-does>-hook

: does-resolved ( ghost -- )
compile does-exec g>xt T a, H ;

: resolve-does>-part ( -- )  : resolve-does>-part ( -- )
\ resolve words made by builders  \ resolve words made by builders
IF    there resolve     IF  there resolve  THEN ;
\ TODO: set special DOES> resolver action here
THEN ;

>TARGET  >TARGET
Cond: DOES>  Cond: DOES>
Line 2453  Cond: DOES> Line 2600  Cond: DOES>
resolve-does>-part          resolve-does>-part
;Cond          ;Cond

: DOES> switchrom doeshandler, T here H !does   : DOES>
instant-interpret-does>-hook      ['] does-resolved created >comp !
depth T ] H ;      switchrom doeshandler, T here H !does
instant-interpret-does>-hook
depth T ] H ;

>CROSS  >CROSS
\ Creation                                              01nov92py  \ Creation                                              01nov92py
Line 2473  Cond: DOES> Line 2622  Cond: DOES>
ghost to built     ghost to built
built >created @ 0= IF    built >created @ 0= IF
built >created on      built >created on
['] prim-resolved built >comp !
THEN ;    THEN ;

: gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
Line 2493  Cond: DOES> Line 2641  Cond: DOES>
;    ;

: takeover-x-semantics ( S constructor-ghost new-ghost -- )  : takeover-x-semantics ( S constructor-ghost new-ghost -- )
\g stores execution semantic and compilation semantic in the built word     \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,     \ we use the >exec2 field for the semantic of a created word,
\ using exec or exec2 makes no difference for normal cross-compilation     \ using exec or exec2 makes no difference for normal cross-compilation
\ but is usefull for instant where the exec field is already     \ but is usefull for instant where the exec field is already
Line 2502  Cond: DOES> Line 2650  Cond: DOES>
2dup >exec @ swap >exec2 !      2dup >exec @ swap >exec2 !
>comp @ swap >comp ! ;     >comp @ swap >comp ! ;

0 Value createhere

: create-resolve ( -- )
created createhere resolve 0 ;Resolve ! ;
: create-resolve-immediate ( -- )
create-resolve T immediate H ;

: TCreate ( <name> -- )  : TCreate ( <name> -- )
create-forward-warn    create-forward-warn
IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
dup >created on    dup >created on  dup to created
2dup takeover-x-semantics hereresolve gdoes, ;    2dup takeover-x-semantics
there to createhere drop gdoes, ;

: RTCreate ( <name> -- )  : RTCreate ( <name> -- )
\ creates a new word with code-field in ram  \ creates a new word with code-field in ram
Line 2515  Cond: DOES> Line 2671  Cond: DOES>
IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
\ make Alias    \ make Alias
dup >created on    dup >created on  dup to created
2dup takeover-x-semantics    2dup takeover-x-semantics
there 0 T a, H alias-mask flag!    there 0 T a, H alias-mask flag!
\ store poiter to code-field    \ store poiter to code-field
switchram T cfalign H    switchram T cfalign H
there swap T ! H    there swap T ! H
there tlastcfa !     there tlastcfa !
hereresolve gdoes, ;    there to createhere drop gdoes, ;

: Build:  ( -- [xt] [colon-sys] )  : Build:  ( -- [xt] [colon-sys] )
:noname postpone TCreate ;    :noname postpone TCreate ;
Line 2536  Cond: DOES> Line 2692  Cond: DOES>
[ [THEN] ] ;    [ [THEN] ] ;

: ;Build  : ;Build
postpone ; built >exec ! ; immediate    postpone create-resolve postpone ; built >exec ! ; immediate

: ;Build-immediate
postpone create-resolve-immediate
postpone ; built >exec ! ; immediate

: gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
executed-ghost @ g>body ;    executed-ghost @ g>body ;
Line 2661  BuildSmart:  ( -- ) [T'] noop T A, H ;Bu Line 2821  BuildSmart:  ( -- ) [T'] noop T A, H ;Bu
by: :dodefer ( ghost -- ) X @ texecute ;DO  by: :dodefer ( ghost -- ) X @ texecute ;DO

Builder interpret/compile:  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  DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO

\ Sturctures                                           23feb95py  \ Sturctures                                           23feb95py
Line 2704  DO:  abort" Not in cross mode" ;DO Line 2864  DO:  abort" Not in cross mode" ;DO
\ this section defines different compilation  \ this section defines different compilation
\ actions for created words  \ actions for created words
\ this will help the peephole optimizer  \ 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  \ changes but seperated it from the original
\ Builder words. The final plan is to put this  \ Builder words. The final plan is to put this
\ into a seperate file, together with the peephole  \ into a seperate file, together with the peephole
Line 2714  DO:  abort" Not in cross mode" ;DO Line 2874  DO:  abort" Not in cross mode" ;DO
T has? peephole H [IF]  T has? peephole H [IF]

>CROSS  >CROSS

: (callc) compile call T >body a, H ;           ' (callc) plugin-of colon,  : (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  \ if we want this, we have to spilt aconstant
\ and constant!!  \ and constant!!
Line 2722  T has? peephole H [IF] Line 2890  T has? peephole H [IF]
\ compile: g>body X @ lit, ;compile  \ compile: g>body X @ lit, ;compile

Builder (Constant)  Builder (Constant)
compile: g>body alit, compile @ ;compile  compile: g>body compile lit@ T a, H ;compile

Builder (Value)  Builder (Value)
compile: g>body alit, compile @ ;compile  compile: g>body compile lit@ T a, H ;compile

\ this changes also Variable, AVariable and 2Variable  \ this changes also Variable, AVariable and 2Variable
Builder Create  Builder Create
\ compile: g>body alit, ;compile  compile: g>body alit, ;compile

Builder User  Builder User
compile: g>body compile useraddr T @ , H ;compile  compile: g>body compile useraddr T @ , H ;compile

Builder Defer  Builder Defer
compile: g>body alit, compile @ compile execute ;compile  compile: g>body compile lit-perform T A, H ;compile

Builder (Field)  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]  [THEN]

Line 3340  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 3517  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond

: d? d? ;  : d? d? ;

: \D ( -- "debugswitch" )
\G doesn't skip line when debug switch is on  \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  \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  \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: \+ \+ ;Cond  Cond: \+ \+ ;Cond
Cond: \D \D ;Cond  Cond: \D \D ;Cond
Cond: \? \? ;Cond

: ?? bl word find IF execute ELSE drop 0 THEN ;  : ?? bl word find IF execute ELSE drop 0 THEN ;

Line 3420  previous Line 3605  previous
: rot rot ;  : rot rot ;
: drop drop ;  : drop drop ;
: =   = ;  : =   = ;
: <>  <> ;
: 0=   0= ;  : 0=   0= ;
: lshift lshift ;  : lshift lshift ;
: 2/ 2/ ;  : 2/ 2/ ;
Line 3474  previous Line 3660  previous
\ : words       also ghosts   \ : words       also ghosts
\                words previous ;  \                words previous ;
: .s            .s ;  : .s            .s ;
: depth         depth ;
: bye           bye ;  : bye           bye ;

\ dummy  \ dummy

 Removed from v.1.114 changed lines Added in v.1.124

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