Diff for /gforth/cross.fs between versions 1.109 and 1.124

version 1.109, 2001/09/05 13:11:36 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 986  Exists-Warnings on Line 1019  Exists-Warnings on

Variable reuse-ghosts reuse-ghosts off  Variable reuse-ghosts reuse-ghosts off

1 [IF] \ FIXME: define when vocs are ready
: HeaderGhost ( "name" -- ghost )  : HeaderGhost ( "name" -- ghost )
>in @     >in @
bl word count     bl word count
Line 1003  Variable reuse-ghosts reuse-ghosts off Line 1035  Variable reuse-ghosts reuse-ghosts off
\ defined words, this is a workaround    \ defined words, this is a workaround
\ for the redefined \ until vocs work    \ for the redefined \ until vocs work
Make-Ghost ;    Make-Ghost ;
[THEN]

: .ghost ( ghost -- ) >ghostname type ;  : .ghost ( ghost -- ) >ghostname type ;

\ ' >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

Line 1193  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+ ;
: >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=
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 >r r@ last-defined-region !          >body (region)
r@ >rlen ! dup r@ >rstart ! r> >rdp !
THEN ;    THEN ;

\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 1359  T has? rom H Line 1409  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 1385  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 1402  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 1496  bigendian Line 1549  bigendian
2drop 0 ;    2drop 0 ;

-1 ABORT" Address out of range!"          -1 ABORT" Address out of range!"
Line 1511  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 1559  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 1568  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 1591  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 1612  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 1640  T has? relocate H Line 1735  T has? relocate H
>TARGET  >TARGET

: count dup X c@ swap X char+ swap ;  : count dup X c@ swap X char+ swap ;
\ FIXME -1 on 64 bit machines?!?!
: on            T -1 swap ! H ;   : on            -1 -1 rot TD!  ;
: off           T 0 swap ! H ;  : off           T 0 swap ! H ;

: tcmove ( source dest len -- )  : tcmove ( source dest len -- )
Line 1672  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 1683  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 1710  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 1769  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 activated
: 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

\ FIXME cleanup
\ : is-resolved   ( ghost -- )
\  >link @ colon, ; \ compile-call

: (gexecute)   ( ghost -- )  : (gexecute)   ( ghost -- )
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 -- )
dup forward? IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;    dup forward? IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;

\ !! : ghost,     ghost  gexecute ;

\ .unresolved                                          11may93jaw  \ .unresolved                                          11may93jaw

variable ResolveFlag  variable ResolveFlag
Line 1946  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 1964  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 1978  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 2059  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 2086  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 2111  Variable last-prim-ghost Line 2244  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 2176  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 2199  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 2219  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 2257  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 2288  Cond: ALiteral ( n -- )   alit, ;Cond Line 2434  Cond: ALiteral ( n -- )   alit, ;Cond
Cond: [Char]   ( "<char>" -- )  Char  lit, ;Cond  Cond: [Char]   ( "<char>" -- )  Char  lit, ;Cond

tchar 1 = [IF]  tchar 1 = [IF]
\ Cond: chars ;Cond   Cond: chars ;Cond
[THEN]  [THEN]

\ some special literals                                 27jan97jaw  \ some special literals                                 27jan97jaw
Line 2324  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 2344  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 2362  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 2376  Cond: MAXI Line 2526  Cond: MAXI
\ by the way: defining a second interpreter (a compiler-)loop  \ by the way: defining a second interpreter (a compiler-)loop
\             is not allowed if a system should be ans conform  \             is not allowed if a system should be ans conform

: (:) ( ghost -- )
\ common factor of : and :noname. Prepare ;Resolve and start definition
;Resolve ! there ;Resolve cell+ !
docol, ]comp  colon-start depth T ] H ;

: : ( -- colon-sys ) \ Name  : : ( -- colon-sys ) \ Name
defempty?    defempty?
constflag off \ don't let this flag work over colon defs    constflag off \ don't let this flag work over colon defs
\ just to go sure nothing unwanted happens                  \ just to go sure nothing unwanted happens
>in @ skip? IF  drop skip-defs  EXIT  THEN  >in !    >in @ skip? IF  drop skip-defs  EXIT  THEN  >in !
docol, ]comp  colon-start depth T ] H ;

: :noname ( -- colon-sys )  : :noname ( -- colon-sys )
X cfalign    X cfalign there
\ FIXME: cleanup!!!!!!!!    \ define a nameless ghost
\ idtentical to : with dummy ghost?!    here ghostheader dup last-header-ghost ! dup to lastghost
here ghostheader dup ;Resolve ! dup last-header-ghost ! to lastghost    (:) ;
there ;Resolve cell+ !
there docol, ]comp
colon-start depth T ] H ;

Cond: EXIT ( -- )   compile ;S  ;Cond  Cond: EXIT ( -- )   compile ;S  ;Cond

Line 2414  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 2424  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 2451  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 2471  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 2491  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
\g if the word already has a semantic (concerns S", IS, .", DOES>)     swap >do:ghost @ 2dup swap >do:ghost !
\g then keep it     \ we use the >exec2 field for the semantic of a created word,
swap >do:ghost @      \ using exec or exec2 makes no difference for normal cross-compilation
\ we use the >exec2 field for the semantic of a crated word,     \ but is usefull for instant where the exec field is already
\ so predefined semantics e.g. for ....     \ defined (e.g. Vocabularies)
\ FIXME: find an example in the normal kernel!!!
2dup >exec @ swap >exec2 !      2dup >exec @ swap >exec2 !
\   cr ." XXX" over .ghost
\   dup >comp @ xt-see
>comp @ swap >comp ! ;     >comp @ swap >comp ! ;
\ old version of this:
\  >exec dup @ ['] NoExec =   0 Value createhere
\  IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ;
: create-resolve ( -- )
created createhere resolve 0 ;Resolve ! ;
: create-resolve-immediate ( -- )
create-resolve T immediate H ;

: TCreate ( <name> -- )  : 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 2519  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 2540  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 @    executed-ghost @ g>body ;
\ FIXME: cleanup
\  compiling? ABORT" CROSS: Executing gdoes> while compiling"
\ ?! compiling? IF  gexecute true EXIT  THEN
g>body ( false ) ;

\ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
\ changed to ?EXIT                                      10may93jaw

: do:ghost! ( ghost -- ) built >do:ghost ! ;  : do:ghost! ( ghost -- ) built >do:ghost ! ;
: doexec! ( xt -- ) built >do:ghost @ >exec ! ;  : doexec! ( xt -- ) built >do:ghost @ >exec ! ;

: DO:     ( -- [xt] [colon-sys] )  : DO:     ( -- [xt] [colon-sys] )
:noname postpone gdoes> ( postpone ?EXIT ) ;    :noname postpone gdoes> ;

: by:     ( -- [xt] [colon-sys] ) \ name  : by:     ( -- [xt] [colon-sys] ) \ name
Ghost do:ghost!    Ghost do:ghost!
:noname postpone gdoes> ( postpone ?EXIT ) ;    :noname postpone gdoes> ;

: ;DO ( [xt] [colon-sys] -- )  : ;DO ( [xt] [colon-sys] -- )
postpone ; doexec! ; immediate    postpone ; doexec! ; immediate
Line 2670  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 2713  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 2723  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 2731  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 3023  magic 7 + c! Line 3191  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 3039  magic 7 + c! Line 3207  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 3050  magic 7 + c! Line 3218  magic 7 + c!
swap >image swap r@ write-file throw    swap >image swap r@ write-file throw
r> close-file throw ;    r> close-file throw ;

1 [IF]  \ save-asm-region                                       29aug01jaw

Variable name-ptr  Variable name-ptr
Create name-buf 200 chars allot  Create name-buf 200 chars allot
Line 3104  Create name-buf 200 chars allot Line 3272  Create name-buf 200 chars allot
THEN    THEN
@nb ;    @nb ;

\ FIXME why disabled?!
: label-from-ghostnameXX ( ghost -- addr len )  : label-from-ghostnameXX ( ghost -- addr len )
\ same as (label-from-ghostname) but caches generated names  \ same as (label-from-ghostname) but caches generated names
dup >asm-name @ ?dup IF nip count EXIT THEN    dup >asm-name @ ?dup IF nip count EXIT THEN
Line 3257  Variable outfile-fd Line 3426  Variable outfile-fd
: save-asm-region ( region adr len -- )  : save-asm-region ( region adr len -- )
create-outfile (save-asm-region) close-outfile ;    create-outfile (save-asm-region) close-outfile ;

[THEN]

\ \ minimal definitions  \ \ minimal definitions

>MINIMAL also minimal  >MINIMAL also minimal
Line 3350  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 3430  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 3484  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
Line 3527  UNLOCK >CROSS Line 3704  UNLOCK >CROSS
[IFDEF] extend-cross extend-cross [THEN]  [IFDEF] extend-cross extend-cross [THEN]

LOCK  LOCK

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

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