### Diff for /gforth/cross.fs between versions 1.111 and 1.123

version 1.111, 2001/09/06 08:14:16 version 1.123, 2002/03/21 16:35:18
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 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 - 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

s" relocate" T environment? H   s" relocate" T environment? H
\ JAW why set NIL to this?!  \ JAW why set NIL to this?!
[IF]    drop \ SetValue NIL  [IF]    drop \ SetValue NIL
[ELSE]  >ENVIRON T NIL H SetValue relocate  [ELSE]  >ENVIRON X NIL SetValue relocate
[THEN]  [THEN]
>TARGET

0 Constant NIL

>CROSS  >CROSS

: >rlen cell+ ;  : >rlen cell+ ;
: >rstart ;  : >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 ! ;

: 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=
region-link linked 0 , 0 , 0 , bl word count string,          region-link linked 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 >r r@ last-defined-region !          >body (region)
r@ >rlen ! dup r@ >rstart ! r> >rdp !
THEN ;    THEN ;

Line 1356  T has? rom H Line 1404  T has? rom H

\ MakeKernel                                                    22feb99jaw  \ MakeKernel                                                    22feb99jaw

: makekernel ( targetsize -- targetsize )  : makekernel ( 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
100 swap dictionary (region)
setup-target ;

>MINIMAL  >MINIMAL
: makekernel makekernel ;  : makekernel makekernel ;
Line 1382  variable sromdp  \ start of rom-area for Line 1433  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 1399  variable constflag constflag off Line 1450  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 1493  bigendian Line 1544  bigendian
2drop 0 ;    2drop 0 ;

-1 ABORT" Address out of range!"          -1 ABORT" Address out of range!"
Line 1609  T has? relocate H Line 1662  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 1669  previous Line 1738  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 1680  previous Line 1749  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 1707  previous Line 1775  previous
sourceline# ,       sourceline# ,
space>      space>
;  ;

: refered ( ghost tag -- )  : refered ( ghost tag -- )
\G creates a resolve structure  \G creates a resolve structure
Line 1766  Defer resolve-warning Line 1834  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 1815  Defer resolve-warning Line 1913  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 1937  Variable to-doc  to-doc on Line 2035  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 1955  Create tag-bof 1 c,  0C c, Line 2055  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 1969  Create tag-bof 1 c,  0C c, Line 2069  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 2050  Defer setup-execution-semantics Line 2166  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 2077  Variable aprim-nr -20 aprim-nr ! Line 2189  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 2102  Variable last-prim-ghost Line 2215  Variable last-prim-ghost

Defer setup-prim-semantics  Defer setup-prim-semantics

: aprim   ( -- )   : mapprim   ( "forthname" "asmlabel" -- )
THeader -1 aprim-nr +! aprim-nr @ T A, H    THeader -1 aprim-nr +! aprim-nr @ T A, H
asmprimname,     asmprimname,
setup-prim-semantics ;    setup-prim-semantics ;

: aprim:   ( -- )   : 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 2167  Comment (       Comment \ Line 2282  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 2190  Cond: [']  T ' H alit, ;Cond Line 2304  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 2210  T 2 cells H Value xt>body Line 2325  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 2248  Defer (end-code) Line 2365  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 2315  Cond: MAXI Line 2441  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 2335  Cond: MAXI Line 2462  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 2353  Cond: MAXI Line 2481  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 2406  Cond: ; ( -- ) Line 2536  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 2416  Cond: [ ( -- ) interpreting-state ;Cond Line 2546  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 2443  Cond: DOES> Line 2571  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 2463  Cond: DOES> Line 2593  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 2483  Cond: DOES> Line 2612  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 2492  Cond: DOES> Line 2621  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 2505  Cond: DOES> Line 2642  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 2526  Cond: DOES> Line 2663  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 2651  BuildSmart:  ( -- ) [T'] noop T A, H ;Bu Line 2792  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 2694  DO:  abort" Not in cross mode" ;DO Line 2835  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 2704  DO:  abort" Not in cross mode" ;DO Line 2845  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 2712  T has? peephole H [IF] Line 2861  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 3004  magic 7 + c! Line 3162  magic 7 + c!
: save-cross ( "image-name" "binary-name" -- )  : save-cross ( "image-name" "binary-name" -- )
bl parse ." Saving to " 2dup type cr    bl parse ." Saving to " 2dup type cr
w/o bin create-file throw >r    w/o bin create-file throw >r
TNIL IF    s" header" X \$has? IF
s" #! "           r@ write-file throw        s" #! "           r@ write-file throw
bl parse          r@ write-file throw        bl parse          r@ write-file throw
s"  --image-file" r@ write-file throw        s"  --image-file" r@ write-file throw
Line 3020  magic 7 + c! Line 3178  magic 7 + c!
THEN    THEN
image @ there     image @ there
r@ write-file throw \ write image    r@ write-file throw \ write image
TNIL IF    s" relocate" X \$has? IF
bit\$  @ there 1- tcell>bit rshift 1+        bit\$  @ there 1- tcell>bit rshift 1+
r@ write-file throw \ write tags                  r@ write-file throw \ write tags
THEN    THEN
Line 3330  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 3488  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 3410  previous Line 3576  previous
: rot rot ;  : rot rot ;
: drop drop ;  : drop drop ;
: =   = ;  : =   = ;
: <>  <> ;
: 0=   0= ;  : 0=   0= ;
: lshift lshift ;  : lshift lshift ;
: 2/ 2/ ;  : 2/ 2/ ;
Line 3464  previous Line 3631  previous
\ : words       also ghosts   \ : words       also ghosts
\                words previous ;  \                words previous ;
: .s            .s ;  : .s            .s ;
: depth         depth ;
: bye           bye ;  : bye           bye ;

\ dummy  \ dummy
Line 3507  UNLOCK >CROSS Line 3675  UNLOCK >CROSS
[IFDEF] extend-cross extend-cross [THEN]  [IFDEF] extend-cross extend-cross [THEN]

LOCK  LOCK

 Removed from v.1.111 changed lines Added in v.1.123

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