gforth/cross.fs - diff

Return to cross.fs CVS log

Up to [gforth] / gforth

Diff for /gforth/cross.fs between versions 1.119 and 1.126

version 1.119, 2002/01/05 22:58:59	version 1.126, 2002/03/21 17:26:00
Line 27 ToDo:	Line 27 ToDo:
cross.fs is used seperately. jaw	cross.fs is used seperately. jaw
- Do we need this char translation with >address and in branchoffset?	- Do we need this char translation with >address and in branchoffset?
(>body also affected) jaw	(>body also affected) jaw
- MAXU etc. can be done with dlit,

[THEN]	[THEN]

Line 71 H	Line 70 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 249 hex \ the defualt base for the cross	Line 252 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
: comment? ( c-addr u -- c-addr u )	: comment? ( c-addr u -- c-addr u )
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 310 set-order previous	Line 318 set-order previous
\ POSTPONE false	\ POSTPONE false
THEN ; immediate	THEN ; immediate

	: symentry ( adr len taddr -- )
	\G Produce a symbol table (an optional symbol address
	\G map) if wanted
	[ [IFDEF] fd-symbol-table ]
	base @ swap hex s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base !
	s" :" fd-symbol-table write-file throw
	fd-symbol-table write-line throw
	[ [ELSE] ]
	2drop drop
	[ [THEN] ] ;


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

decimal	decimal
Line 712 Plugin branchtoresolve, ( branch-addr --	Line 732 Plugin branchtoresolve, ( branch-addr --
Plugin branchtomark, ( -- target-addr ) \ marks a branch destination	Plugin branchtomark, ( -- target-addr ) \ marks a branch destination

Plugin colon, ( tcfa -- ) \ compiles call to tcfa at current position	Plugin colon, ( tcfa -- ) \ compiles call to tcfa at current position
Plugin xt, ( tcfa -- ) \ compiles xt
Plugin prim, ( tcfa -- ) \ compiles primitive invocation	Plugin prim, ( tcfa -- ) \ compiles primitive invocation
Plugin colonmark, ( -- addr ) \ marks a colon call	Plugin colonmark, ( -- addr ) \ marks a colon call
Plugin colon-resolve ( tcfa addr -- )	Plugin colon-resolve ( tcfa addr -- )
Line 746 Plugin next, ( for-token )	Line 765 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
	\ convert the addresses.
	\ The only target where we need this is the misc
	\ which is a 16 Bit processor with word addresses
	\ but the forth system we build has a normal byte
	\ addressed memory model

Plugin doprim, \ compiles start of a primitive	Plugin doprim, \ compiles start of a primitive
Plugin docol, \ compiles start of a colon definition	Plugin docol, \ compiles start of a colon definition
Line 899 Variable cross-space-dp-orig	Line 923 Variable cross-space-dp-orig
THEN ;	THEN ;

Defer is-forward	Defer is-forward
Defer do-refered

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

: (ghostheader) ( -- )	: (ghostheader) ( -- )
ghost-list linked <fwd> , 0 , ['] NoExec , what's 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 , ;

: ghostheader ( -- ) (ghostheader) 0 , ;	: ghostheader ( -- ) (ghostheader) 0 , ;
Line 1085 Ghost lit-perform drop	Line 1102 Ghost lit-perform drop
Ghost lit+ drop	Ghost lit+ drop
Ghost does-exec drop	Ghost does-exec drop

' doer-forward IS is-forward

Ghost :docol Ghost :doesjump Ghost :dodoes 2drop drop	Ghost :docol Ghost :doesjump Ghost :dodoes 2drop drop
Ghost :dovar drop	Ghost :dovar drop

' prim-forward IS is-forward

\ \ Parameter for target systems 06oct92py	\ \ Parameter for target systems 06oct92py


Line 1221 tbits/char bits/byte / Constant tbyte	Line 1234 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$

Line 1245 Variable region-link \ linked	Line 1259 Variable region-link \ linked
Variable mirrored-link \ linked list for mirrored regions	Variable mirrored-link \ linked list for mirrored regions
0 dup mirrored-link ! region-link !	0 dup mirrored-link ! region-link !

	: >rname 8 cells + ;
: >rname 7 cells + ;	: >rbm 4 cells + ; \ bitfield per cell witch indicates relocation
: >rbm 4 cells + ;
: >rmem 5 cells + ;	: >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+ ;
Line 1260 Variable mirrored-link \ linked	Line 1274 Variable mirrored-link \ linked
>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=
Line 1269 Variable mirrored-link \ linked	Line 1283 Variable mirrored-link \ linked
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)
Line 1287 Variable mirrored-link \ linked	Line 1301 Variable mirrored-link \ linked
\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
mirrored-link	mirrored-link
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 1419 variable sromdp \ start of rom-area for	Line 1437 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 1436 variable constflag constflag off	Line 1454 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 1530 bigendian	Line 1548 bigendian
2drop 0 ;	2drop 0 ;

: taddr>region-abort ( taddr -- region \| 0 )	: taddr>region-abort ( taddr -- region \| 0 )
	\G Same as taddr>region but aborts if taddr is not
	\G a valid address in the target address space
dup taddr>region dup 0=	dup taddr>region dup 0=
IF drop cr ." Wrong address: " .addr	IF drop cr ." Wrong address: " .addr
-1 ABORT" Address out of range!"	-1 ABORT" Address out of range!"
Line 1545 bigendian	Line 1565 bigendian
\ add regions real address in our memory	\ add regions real address in our memory
r> >rmem @ + ;	r> >rmem @ + ;

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

: (>regionbm) ( taddr -- 'taddr bitmaskbaseaddr )	: (>regionbm) ( taddr -- 'taddr bitmaskbaseaddr )
dup	dup
\ find region we want to address	\ find region we want to address
Line 1593 CREATE Bittable 80 c, 40 c, 20 c, 10 c,	Line 1625 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
: (>image) ( taddr -- absaddr ) image @ + ;	: (>image) ( taddr -- absaddr ) image @ + ;

DEFER >image	DEFER >image
	DEFER >ramimage
DEFER relon	DEFER relon
DEFER reloff	DEFER reloff
DEFER correcter	DEFER correcter
Line 1602 T has? relocate H	Line 1635 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 1625 T has? relocate H	Line 1669 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 1650 T has? relocate H	Line 1694 T has? relocate H

>CROSS	>CROSS

: call-forward ( ghost -- )
there 0 colon, 0 do-refered ;
' call-forward IS is-forward

Ghost (do) Ghost (?do) 2drop	Ghost (do) Ghost (?do) 2drop
Ghost (for) drop	Ghost (for) drop
Ghost (loop) Ghost (+loop) 2drop	Ghost (loop) Ghost (+loop) 2drop
Line 1663 Ghost (.") Ghost (S") Ghost (A	Line 1703 Ghost (.") Ghost (S") Ghost (A
Ghost (C") drop	Ghost (C") drop
Ghost ' drop	Ghost ' drop

\ ' prim-forward IS is-forward

\ user ghosts	\ user ghosts

Ghost state drop	Ghost state drop
Line 1726 previous	Line 1764 previous
>CROSS	>CROSS

: (cc) T a, H ; ' (cc) plugin-of colon,	: (cc) T a, H ; ' (cc) plugin-of colon,
: (xt) T a, H ; ' (xt) plugin-of xt,
: (prim) T a, H ; ' (prim) plugin-of prim,	: (prim) T a, H ; ' (prim) plugin-of prim,

: (cr) >tempdp colon, tempdp> ; ' (cr) plugin-of colon-resolve	: (cr) >tempdp colon, tempdp> ; ' (cr) plugin-of colon-resolve
Line 1740 previous	Line 1777 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 xt, ; ' (cm) plugin-of colonmark,

>TARGET	>TARGET
: compile, ( xt -- )	: compile, ( xt -- )
Line 1769 previous	Line 1805 previous
space>	space>
;	;

' (refered) IS do-refered

: refered ( ghost tag -- )	: refered ( ghost tag -- )
\G creates a resolve structure	\G creates a resolve structure
T here aligned H swap (refered)	T here aligned H swap (refered)
Line 1828 Defer resolve-warning	Line 1862 Defer resolve-warning
>link ! ;	>link ! ;

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

: prim-resolved ( ghost -- )	: prim-resolved ( ghost -- )
	\ compiles a call to a primitive
>link @ prim, ;	>link @ prim, ;

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

0 Value resolved	0 Value resolved

: resolve ( ghost tcfa -- )	: resolve-forward-references ( ghost resolve-list -- )
\G resolve referencies to ghost with tcfa	\ loop through forward referencies
	comp-state @ >r Resolving comp-state !
	over >link @ resolve-loop
	r> comp-state !

	['] noop IS resolve-warning ;


	: (resolve) ( ghost tcfa -- ghost resolve-list )
	\ check for a valid address, it is a primitive reference
	\ otherwise
dup taddr>region 0<> IF	dup taddr>region 0<> IF
	\ define this address in the region address type table
2dup (>regiontype) define-addr-struct addr-xt-ghost	2dup (>regiontype) define-addr-struct addr-xt-ghost

\ 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
\ get linked-list	(resolve)
swap >r r@ >link @ swap \ ( list tcfa R: ghost )	( ghost resolve-list )
\ mark ghost as resolved	resolve-forward-references ;
dup r@ >link ! <res> r@ >magic !
r@ to resolved	: resolve-noforwards ( ghost tcfa -- )
r@ >comp @ ['] prim-forward = IF	\G Same as resolve but complain if there are any
['] prim-resolved r@ >comp ! THEN	\G forward references on this ghost
r@ >comp @ what's is-forward = IF	\ is ghost resolved?, second resolve means another
['] prim-resolved r@ >comp ! THEN	\ definition with the same name
\ loop through forward referencies	over undefined? 0= IF exists EXIT THEN
r> -rot	(resolve)
comp-state @ >r Resolving comp-state !	IF cr ." No forward references allowed on: " .ghost cr
resolve-loop	-1 ABORT" Illegal forward reference"
r> comp-state !	THEN
	drop ;
['] noop IS resolve-warning
;

\ gexecute ghost, 01nov92py	\ gexecute ghost, 01nov92py

Line 1874 Defer resolve-warning	Line 1941 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 2127 Defer setup-execution-semantics	Line 2194 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 !
HeaderGhost	HeaderGhost
\ 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
alias-mask flag!	alias-mask flag!
Line 2187 Defer setup-prim-semantics	Line 2250 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, ;

: Doer: ( cfa -- ) \ name	: Doer: ( cfa -- ) \ name
Line 2197 Defer setup-prim-semantics	Line 2260 Defer setup-prim-semantics
.sourcepos ." needs doer: " >in @ bl word count type >in ! cr	.sourcepos ." needs doer: " >in @ bl word count type >in ! cr
THEN	THEN
Ghost	Ghost
tuck swap resolve <do:> swap >magic ! ;	tuck swap resolve-noforwards <do:> swap >magic ! ;

Variable prim#	Variable prim#
: first-primitive ( n -- ) prim# ! ;	: first-primitive ( n -- ) prim# ! ;
Line 2208 Variable prim#	Line 2271 Variable prim#
.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 2289 T 2 cells H Value xt>body	Line 2353 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,

Line 2327 Defer (end-code)	Line 2393 Defer (end-code)
>TARGET	>TARGET
: Code	: Code
defempty?	defempty?
(THeader there resolve	(THeader ( ghost )
	['] prim-resolved over >comp !
	there resolve-noforwards

[ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]	[ 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 2363 Cond: chars ;Cond	Line 2438 Cond: chars ;Cond

\ some special literals 27jan97jaw	\ some special literals 27jan97jaw

\ !! Known Bug: Special Literals and plug-ins work only correct
\ on 16 and 32 Bit Targets and 32 Bit Hosts!

\ This section could be done with dlit, now. But first I need
\ some test code JAW

Cond: MAXU	Cond: MAXU
tcell 1 cells u>	-1 s>d dlit,
IF compile lit tcell 0 ?DO FF T c, H LOOP
ELSE ffffffff lit, THEN
;Cond	;Cond

	tcell 2 = tcell 4 = or tcell 8 = or 0=
	[IF]
	.( Warning: MINI and MAXI may not work with this host) cr
	[THEN]

Cond: MINI	Cond: MINI
tcell 1 cells u>	tcell 2 = IF $8000 ELSE $80000000 THEN 0
IF compile lit bigendian	tcell 8 = IF swap THEN dlit,
IF 80 T c, H tcell 1 ?DO 0 T c, H LOOP
ELSE tcell 1 ?DO 0 T c, H LOOP 80 T c, H
THEN
ELSE tcell 2 = IF 8000 ELSE 80000000 THEN lit, THEN
;Cond	;Cond

Cond: MAXI	Cond: MAXI
tcell 1 cells u>	tcell 2 = IF $7fff ELSE $7fffffff THEN 0
IF compile lit bigendian	tcell 8 = IF drop -1 swap THEN dlit,
IF 7F T c, H tcell 1 ?DO FF T c, H LOOP	;Cond
ELSE tcell 1 ?DO FF T c, H LOOP 7F T c, H
THEN
ELSE tcell 2 = IF 7fff ELSE 7fffffff THEN lit, THEN
;Cond

>CROSS	>CROSS

Line 2504 Cond: [ ( -- ) interpreting-state ;Cond	Line 2568 Cond: [ ( -- ) interpreting-state ;Cond
: !does ( does-action -- )	: !does ( does-action -- )
tlastcfa @ [G'] :dovar killref	tlastcfa @ [G'] :dovar killref
>space here >r ghostheader space>	>space here >r ghostheader space>
	['] colon-resolved r@ >comp !
r@ created >do:ghost ! r@ swap resolve	r@ created >do:ghost ! r@ swap resolve
r> tlastcfa @ >tempdp dodoes, tempdp> ;	r> tlastcfa @ >tempdp dodoes, tempdp> ;

Line 2787 DO: abort" Not in cross mode" ;DO	Line 2852 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 2799 T has? peephole H [IF]	Line 2864 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) >tempdp resolved gexecute tempdp> drop ;
' (call-res) plugin-of colon-resolve	' (call-res) plugin-of colon-resolve
: (prim) dup 0< IF $4000 - ELSE	: (pprim) dup 0< IF $4000 - ELSE
." wrong usage of (prim) "	cr ." wrong usage of (prim) "
dup gdiscover IF .ghost ELSE . THEN cr -2 throw THEN	dup gdiscover IF .ghost ELSE . THEN cr -1 throw THEN
T a, H ; ' (prim) plugin-of prim,	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 3286 Variable outfile-fd	Line 3352 Variable outfile-fd
dup @ dup IF addr-refs @ THEN	dup @ dup IF addr-refs @ THEN
swap >r	swap >r
over align+ tuck tcell swap - rshift swap 0	over align+ tuck tcell swap - rshift swap 0
DO dup 1 and	?DO dup 1 and
IF drop rdrop snl-calc UNLOOP EXIT THEN	IF drop rdrop snl-calc UNLOOP EXIT THEN
2/ swap 1+ swap	2/ swap 1+ swap
LOOP	LOOP
Line 3439 Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond	Line 3505 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 3519 previous	Line 3593 previous
: rot rot ;	: rot rot ;
: drop drop ;	: drop drop ;
: = = ;	: = = ;
	: <> <> ;
: 0= 0= ;	: 0= 0= ;
: lshift lshift ;	: lshift lshift ;
: 2/ 2/ ;	: 2/ 2/ ;
Line 3573 previous	Line 3648 previous
\ : words also ghosts	\ : words also ghosts
\ words previous ;	\ words previous ;
: .s .s ;	: .s .s ;
	: depth depth ;
: bye bye ;	: bye bye ;

\ dummy	\ dummy

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

Removed from v.1.119
changed lines
	Added in v.1.126