gforth/cross.fs - diff

Return to cross.fs CVS log

Up to [gforth] / gforth

Diff for /gforth/cross.fs between versions 1.53 and 1.76

version 1.53, 1997/09/13 12:04:55	version 1.76, 1999/05/17 13:12:25
Line 1	Line 1
\ CROSS.FS The Cross-Compiler 06oct92py	\ CROSS.FS The Cross-Compiler 06oct92py
\ Idea and implementation: Bernd Paysan (py)	\ Idea and implementation: Bernd Paysan (py)

\ Copyright (C) 1995 Free Software Foundation, Inc.	\ Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.

\ This file is part of Gforth.	\ This file is part of Gforth.

Line 19	Line 19
\ along with this program; if not, write to the Free Software	\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.	\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

\ Log:	0
\ changed in ; [ to state off 12may93jaw	[IF]
\ included place +place 12may93jaw
\ for a created word (variable, constant...)	ToDo:
\ is now an alias in the target voabulary.	Crossdoc destination ./doc/crossdoc.fd makes no sense when
\ this means it is no longer necessary to	cross.fs is uses seperately. jaw
\ switch between vocabularies for variable	Do we need this char translation with >address and in branchoffset?
\ initialization 12may93jaw	(>body also affected) jaw
\ discovered error in DOES>	Clean up mark> and >resolve stuff jaw
\ replaced !does with (;code) 16may93jaw
\ made complete redesign and	[THEN]
\ introduced two vocs method
\ to be asure that the right words
\ are found 08jun93jaw
\ btw: ! works not with 16 bit
\ targets 09jun93jaw
\ added: 2user and value 11jun93jaw

\ needed? works better now!!! 01mar97jaw
\ mach file is only loaded into target
\ cell corrected
\ romable extansions 27apr97-5jun97jaw


hex \ the defualt base for the cross-compiler is hex !!	hex \ the defualt base for the cross-compiler is hex !!
Line 48 Warnings off	Line 37 Warnings off

\ words that are generaly useful	\ words that are generaly useful

	: KB 400 * ;
: >wordlist ( vocabulary-xt -- wordlist-struct )	: >wordlist ( vocabulary-xt -- wordlist-struct )
also execute get-order swap >r 1- set-order r> ;	also execute get-order swap >r 1- set-order r> ;

Line 59 Warnings off	Line 49 Warnings off
dup c, here swap chars dup allot move ;	dup c, here swap chars dup allot move ;

: SetValue ( n -- <name> )	: SetValue ( n -- <name> )
\G Same behaviour as "Value" when the <name> is not defined	\G Same behaviour as "Value" if the <name> is not defined
\G Same behaviour as "to" when <name> is defined	\G Same behaviour as "to" if <name> is defined
\G SetValue searches in the current vocabulary	\G SetValue searches in the current vocabulary
save-input bl word >r restore-input throw r> count	save-input bl word >r restore-input throw r> count
get-current search-wordlist	get-current search-wordlist
IF bl word drop >body ! ELSE Value THEN ;	IF drop >r
	\ we have to set current to be topmost context wordlist
	get-order get-order get-current swap 1+ set-order
	r> ['] to execute
	set-order
	ELSE Value THEN ;

: DefaultValue ( n -- <name> )	: DefaultValue ( n -- <name> )
\G Same behaviour as "Value" when the <name> is not defined	\G Same behaviour as "Value" if the <name> is not defined
\G SetValue searches in the current vocabulary	\G DefaultValue searches in the current vocabulary
save-input bl word >r restore-input throw r> count	save-input bl word >r restore-input throw r> count
get-current search-wordlist	get-current search-wordlist
IF bl word drop drop drop ELSE Value THEN ;	IF bl word drop 2drop ELSE Value THEN ;

hex	hex

Line 123 also forth definitions \ these values m	Line 118 also forth definitions \ these values m
false DefaultValue stack-warn \ check on empty stack at any definition	false DefaultValue stack-warn \ check on empty stack at any definition
false DefaultValue create-forward-warn \ warn on forward declaration of created words	false DefaultValue create-forward-warn \ warn on forward declaration of created words

[IFUNDEF] DebugMaskSrouce Variable DebugMaskSource 0 DebugMaskSource ! [THEN]
[IFUNDEF] DebugMaskCross Variable DebugMaskCross 0 DebugMaskCross ! [THEN]

previous >CROSS	previous >CROSS

: .dec	: .dec
Line 148 stack-warn [IF]	Line 140 stack-warn [IF]
: defempty? ; immediate	: defempty? ; immediate
[THEN]	[THEN]

	\ debugging

	0 [IF]

	This implements debugflags for the cross compiler and the compiled
	images. It works identical to the has-flags in the environment.
	The debugflags are defined in a vocabluary. If the word exists and
	its value is true, the flag is switched on.

	[THEN]

	Vocabulary debugflags \ debug flags for cross
	also debugflags get-order over
	Constant debugflags-wl
	set-order previous

	: DebugFlag
	get-current >r debugflags-wl set-current
	SetValue
	r> set-current ;

	: Debug? ( adr u -- flag )
	\G return true if debug flag is defined or switched on
	debugflags-wl search-wordlist
	IF EXECUTE
	ELSE false THEN ;

	: D? ( <name> -- flag )
	\G return true if debug flag is defined or switched on
	\G while compiling we do not return the current value but
	bl word count debug? ;

	: [d?]
	\G compile the value-xt so the debug flag can be switched
	\G the flag must exist!
	bl word count debugflags-wl search-wordlist
	IF compile,
	ELSE -1 ABORT" unknown debug flag"
	\ POSTPONE false
	THEN ; immediate

\ \ GhostNames Ghosts 9may93jaw	\ \ GhostNames Ghosts 9may93jaw

Line 175 VARIABLE VocTemp	Line 207 VARIABLE VocTemp
hex	hex
4711 Constant <fwd> 4712 Constant <res>	4711 Constant <fwd> 4712 Constant <res>
4713 Constant <imm> 4714 Constant <do:>	4713 Constant <imm> 4714 Constant <do:>
	4715 Constant <skip>

\ iForth makes only immediate directly after create	\ iForth makes only immediate directly after create
\ make atonce trick! ?	\ make atonce trick! ?

Variable atonce atonce off	Variable atonce atonce off

: NoExec true ABORT" CROSS: Don't execute ghost" ;	: NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;

: GhostHeader <fwd> , 0 , ['] NoExec , ;	: GhostHeader <fwd> , 0 , ['] NoExec , ;

Line 226 VARIABLE Already	Line 259 VARIABLE Already

: ghost ( "name" -- ghost )	: ghost ( "name" -- ghost )
Already off	Already off
>in @ bl word gfind IF Already on nip EXIT THEN	>in @ bl word gfind IF atonce off Already on nip EXIT THEN
drop >in ! Make-Ghost ;	drop >in ! Make-Ghost ;

: >ghostname ( ghost -- adr len )	: >ghostname ( ghost -- adr len )
Line 234 VARIABLE Already	Line 267 VARIABLE Already
BEGIN @ dup	BEGIN @ dup
WHILE 2dup cell+ @ =	WHILE 2dup cell+ @ =
UNTIL nip 2 cells + count	UNTIL nip 2 cells + count
ELSE 2drop true abort" CROSS: Ghostnames inconsistent"	ELSE 2drop
	\ true abort" CROSS: Ghostnames inconsistent"
	s" ?!?!?!"
THEN ;	THEN ;

' >ghostname ALIAS @name	' >ghostname ALIAS @name
Line 242 VARIABLE Already	Line 277 VARIABLE Already
: forward? ( ghost -- flag )	: forward? ( ghost -- flag )
>magic @ <fwd> = ;	>magic @ <fwd> = ;

	: undefined? ( ghost -- flag )
	>magic @ dup <fwd> = swap <skip> = or ;

\ Predefined ghosts 12dec92py	\ Predefined ghosts 12dec92py

ghost 0= drop	ghost 0= drop
Line 256 ghost (does>) ghost noop	Line 294 ghost (does>) ghost noop
ghost (.") ghost (S") ghost (ABORT") 2drop drop	ghost (.") ghost (S") ghost (ABORT") 2drop drop
ghost ' drop	ghost ' drop
ghost :docol ghost :doesjump ghost :dodoes 2drop 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 - drop
	ghost 2drop drop
	ghost 2dup drop

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

Line 271 VARIABLE env-current \ save information	Line 312 VARIABLE env-current \ save information

>TARGET	>TARGET

: environment?	: environment? ( adr len -- [ x ] true \| false )
target-environment search-wordlist	target-environment search-wordlist
IF execute true ELSE false THEN ;	IF execute true ELSE false THEN ;

: e? name T environment? H 0= ABORT" environment variable not defined!" ;	: e? bl word count T environment? H 0= ABORT" environment variable not defined!" ;

: has? name T environment? H	: has? bl word count T environment? H
IF \ environment variable is present, return its value	IF \ environment variable is present, return its value
ELSE \ environment variable is not present, return false	ELSE \ environment variable is not present, return false
\ !! JAW abort is just for testing	false \ debug true ABORT" arg"
false true ABORT" arg"
THEN ;	THEN ;

: $has? T environment? H IF ELSE false THEN ;	: $has? T environment? H IF ELSE false THEN ;

>ENVIRON	>ENVIRON get-order get-current swap 1+ set-order
false SetValue ionly	true SetValue compiler
true SetValue cross	true SetValue cross
>TARGET	true SetValue standard-threading
	>TARGET previous


mach-file count included hex	mach-file count included hex

>ENVIRON	>ENVIRON

s" interpreter" T environment? H 0= ?dup nip [IF] true Value interpreter [THEN]	T has? ec H
s" ITC" T environment? H 0= ?dup nip [IF] true SetValue ITC [THEN]	[IF]
s" rom" T environment? H 0= ?dup nip [IF] false Value rom [THEN]	false DefaultValue relocate
	false DefaultValue file
	false DefaultValue OS
	false DefaultValue prims
	false DefaultValue floating
	false DefaultValue glocals
	false DefaultValue dcomps
	false DefaultValue hash
	false DefaultValue xconds
	false DefaultValue header
	[THEN]

	true DefaultValue interpreter
	true DefaultValue ITC
	false DefaultValue rom
	true DefaultValue standardthreading

>TARGET	>TARGET
s" relocate" T environment? H	s" relocate" T environment? H
Line 309 s" relocate" T environment? H	Line 366 s" relocate" T environment? H

\ \ Create additional parameters 19jan95py	\ \ Create additional parameters 19jan95py

	\ currently cross only works for host machines with address-unit-bits
	\ eual to 8 because of s! and sc!
	\ but I start to query the environment just to modularize a little bit

	: check-address-unit-bits ( -- )
	\ s" ADDRESS-UNIT-BITS" environment?
	\ IF 8 <> ELSE true THEN
	\ ABORT" ADDRESS-UNIT-BITS unknown or not equal to 8!"

	\ shit, this doesn't work because environment? is only defined for
	\ gforth.fi and not kernl???.fi
	;

	check-address-unit-bits
	8 Constant bits/byte \ we define: byte is address-unit

	1 bits/byte lshift Constant maxbyte
	\ this sets byte size for the target machine, an (probably right guess) jaw

T	T
NIL Constant TNIL	NIL Constant TNIL
cell Constant tcell	cell Constant tcell
cell<< Constant tcell<<	cell<< Constant tcell<<
cell>bit Constant tcell>bit	cell>bit Constant tcell>bit
bits/byte Constant tbits/byte	bits/char Constant tbits/char
float Constant tfloat	bits/char H bits/byte T /
1 bits/byte lshift Constant maxbyte	Constant tchar
	float Constant tfloat
	1 bits/char lshift Constant tmaxchar
	[IFUNDEF] bits/byte
	8 Constant tbits/byte
	[ELSE]
	bits/byte Constant tbits/byte
	[THEN]
H	H
	tbits/byte bits/byte / Constant tbyte


\ Variables 06oct92py	\ Variables 06oct92py

Line 332 Variable bit$	Line 417 Variable bit$
Variable headers-named 0 headers-named !	Variable headers-named 0 headers-named !
Variable user-vars 0 user-vars !	Variable user-vars 0 user-vars !

\ Memory initialisation 05dec92py	: target>bitmask-size ( u1 -- u2 )
	1- tcell>bit rshift 1+ ;
[IFDEF] Memory \ Memory is a bigFORTH feature
also Memory
: initmem ( var len -- )
2dup swap handle! >r @ r> erase ;
toss
[ELSE]
: initmem ( var len -- )
tuck allocate abort" CROSS: No memory for target"
( len var adr ) dup rot !
( len adr ) swap erase ;
[THEN]

\ MakeKernal 12dec92py

: makekernel ( targetsize -- targetsize )	: allocatetarget ( size --- adr )
bit$ over 1- tcell>bit rshift 1+ initmem	dup allocate ABORT" CROSS: No memory for target"
image over initmem ;	swap over swap erase ;

>MINIMAL	\ \ memregion.fs
: makekernel makekernel ;


>CROSS

\ memregion.fs


Variable last-defined-region \ pointer to last defined region	Variable last-defined-region \ pointer to last defined region
Line 367 Variable mirrored-link \ linked	Line 433 Variable mirrored-link \ linked
0 dup mirrored-link ! region-link !	0 dup mirrored-link ! region-link !


	: >rname 6 cells + ;
	: >rbm 5 cells + ;
	: >rmem 4 cells + ;
	: >rlink 3 cells + ;
: >rdp 2 cells + ;	: >rdp 2 cells + ;
: >rlen cell+ ;	: >rlen cell+ ;
: >rstart ;	: >rstart ;
Line 380 Variable mirrored-link \ linked	Line 450 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 name string,	region-link linked 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 >r r@ last-defined-region !
r@ cell+ ! dup r@ ! r> 2 cells + !	r@ >rlen ! dup r@ >rstart ! r> >rdp !
THEN ;	THEN ;

: borders ( region -- startaddr endaddr ) \G returns lower and upper region border	: borders ( region -- startaddr endaddr ) \G returns lower and upper region border
dup @ swap cell+ @ over + ;	dup >rstart @ swap >rlen @ over + ;

: extent ( region -- startaddr len ) \G returns the really used area	: extent ( region -- startaddr len ) \G returns the really used area
dup @ swap 2 cells + @ over - ;	dup >rstart @ swap >rdp @ over - ;

: area ( region -- startaddr totallen ) \G returns the total area	: area ( region -- startaddr totallen ) \G returns the total area
dup @ swap cell+ @ ;	dup >rstart swap >rlen @ ;

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

: .addr	: .addr ( u -- )
	\G prints a 16 or 32 Bit nice hex value
base @ >r hex	base @ >r hex
tcell 2 u>	tcell 2 u>
IF s>d <# # # # # '. hold # # # # #> type	IF s>d <# # # # # '. hold # # # # #> type
Line 414 Variable mirrored-link \ linked	Line 485 Variable mirrored-link \ linked
0 region-link @	0 region-link @
BEGIN dup WHILE dup @ REPEAT drop	BEGIN dup WHILE dup @ REPEAT drop
BEGIN dup	BEGIN dup
WHILE cr 3 cells - >r	WHILE cr
r@ 4 cells + count tuck type	0 >rlink - >r
	r@ >rname count tuck type
12 swap - 0 max spaces space	12 swap - 0 max spaces space
." Start: " r@ @ dup .addr space	." Start: " r@ >rstart @ dup .addr space
." End: " r@ 1 cells + @ + .addr space	." End: " r@ >rlen @ + .addr space
." DP: " r> 2 cells + @ .addr	." DP: " r> >rdp @ .addr
REPEAT drop	REPEAT drop
s" rom" T $has? H 0= ?EXIT	s" rom" T $has? H 0= ?EXIT
cr ." Mirrored:"	cr ." Mirrored:"
mirrored-link @	mirrored-link @
BEGIN dup	BEGIN dup
WHILE space dup cell+ @ 4 cells + count type @	WHILE space dup cell+ @ >rname count type @
REPEAT drop cr	REPEAT drop cr
;	;

Line 457 T has? rom H	Line 529 T has? rom H
: setup-target ( -- ) \G initialize targets memory space	: setup-target ( -- ) \G initialize targets memory space
s" rom" T $has? H	s" rom" T $has? H
IF \ check for ram and rom...	IF \ check for ram and rom...
address-space area nip	\ address-space area nip 0<>
ram-dictionary area nip	ram-dictionary area nip 0<>
rom-dictionary area nip	rom-dictionary area nip 0<>
and and 0=	and 0=
ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!"	ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!"
THEN	THEN
address-space area nip	address-space area nip
Line 469 T has? rom H	Line 541 T has? rom H
ELSE	ELSE
dictionary area	dictionary area
THEN	THEN
dup 0=	nip 0=
ABORT" CROSS: define at least address-space or dictionary!!"	ABORT" CROSS: define at least address-space or dictionary!!"
+ makekernel drop ;

\ switched tdp for rom support 03jun97jaw	\ allocate target for each region
	region-link
	BEGIN @ dup
	WHILE dup
	0 >rlink - >r
	r@ >rlen @
	IF \ allocate mem
	r@ >rlen @ dup

	allocatetarget dup image !
	r@ >rmem !

	target>bitmask-size allocatetarget
	dup bit$ !
	r> >rbm !

	ELSE r> drop THEN
	REPEAT drop ;

	\ MakeKernal 22feb99jaw

	: makekernel ( targetsize -- targetsize )
	dup dictionary >rlen ! setup-target ;

	>MINIMAL
	: makekernel makekernel ;
	>CROSS

	\ \ switched tdp for rom support 03jun97jaw

\ second value is here to store some maximal value for statistics	\ second value is here to store some maximal value for statistics
\ tempdp is also embedded here but has nothing to do with rom support	\ tempdp is also embedded here but has nothing to do with rom support
Line 507 variable fixed \ flag: true: no automat	Line 606 variable fixed \ flag: true: no automat

variable constflag constflag off	variable constflag constflag off

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

: (switchram)	: (switchram)
fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT	fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT
ram-dictionary >rdp to tdp ;	ram-dictionary activate ;

: switchram	: switchram
constflag @	constflag @
IF constflag off ELSE (switchram) THEN ;	IF constflag off ELSE (switchram) THEN ;

: switchrom	: switchrom
fixed @ ?EXIT rom-dictionary >rdp to tdp ;	fixed @ ?EXIT rom-dictionary activate ;

: >tempdp ( addr -- )	: >tempdp ( addr -- )
tdp tempdp-save ! tempdp to tdp tdp ! ;	tdp tempdp-save ! tempdp to tdp tdp ! ;
Line 532 variable constflag constflag off	Line 635 variable constflag constflag off
\ : romstart dup sromdp ! romdp ! ;	\ : romstart dup sromdp ! romdp ! ;
\ : ramstart dup sramdp ! ramdp ! ;	\ : ramstart dup sramdp ! ramdp ! ;

\ default compilation goed to rom	\ default compilation goes to rom
\ when romable support is off, only the rom switch is used (!!)	\ when romable support is off, only the rom switch is used (!!)
>auto	>auto

Line 546 variable constflag constflag off	Line 649 variable constflag constflag off

: cell+ tcell + ;	: cell+ tcell + ;
: cells tcell<< lshift ;	: cells tcell<< lshift ;
: chars ;	: chars tchar * ;
: char+ 1 + ;	: char+ tchar + ;
: floats tfloat * ;	: floats tfloat * ;

>CROSS	>CROSS
Line 564 bigendian	Line 667 bigendian
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;	DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
: S@ ( addr -- n ) >r 0 0 r> tcell bounds	: S@ ( addr -- n ) >r 0 0 r> tcell bounds
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;	DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;
	: Sc! ( n addr -- ) >r s>d r> tchar bounds swap 1-
	DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
	: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds
	DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;
[ELSE]	[ELSE]
: S! ( n addr -- ) >r s>d r> tcell bounds	: S! ( n addr -- ) >r s>d r> tcell bounds
DO maxbyte ud/mod rot I c! LOOP 2drop ;	DO maxbyte ud/mod rot I c! LOOP 2drop ;
: S@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1-	: S@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1-
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;	DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
	: Sc! ( n addr -- ) >r s>d r> tchar bounds
	DO maxbyte ud/mod rot I c! LOOP 2drop ;
	: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds swap 1-
	DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
[THEN]	[THEN]

>CROSS	: taddr>region ( taddr -- region \| 0 )
	\G finds for a target-address the correct region
	\G returns 0 if taddr is not in range of a target memory region
	region-link
	BEGIN @ dup
	WHILE dup >r
	0 >rlink - >r
	r@ >rlen @
	IF dup r@ borders within
	IF r> r> drop nip EXIT THEN
	THEN
	r> drop
	r>
	REPEAT
	2drop 0 ;

	: (>regionimage) ( taddr -- 'taddr )
	dup
	\ find region we want to address
	taddr>region dup 0= ABORT" Address out of range!"
	>r
	\ calculate offset in region
	r@ >rstart @ -
	\ add regions real address in our memory
	r> >rmem @ + ;

\ Bit string manipulation 06oct92py	\ Bit string manipulation 06oct92py
\ 9may93jaw	\ 9may93jaw
CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,	CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
Line 580 CREATE Bittable 80 c, 40 c, 20 c, 10 c,	Line 716 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
: >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;	: >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
: +bit ( addr n -- ) >bit over c@ or swap c! ;	: +bit ( addr n -- ) >bit over c@ or swap c! ;
: -bit ( addr n -- ) >bit invert over c@ and swap c! ;	: -bit ( addr n -- ) >bit invert over c@ and swap c! ;
: relon ( taddr -- ) bit$ @ swap cell/ +bit ;
: reloff ( taddr -- ) bit$ @ swap cell/ -bit ;	: (relon) ( taddr -- ) bit$ @ swap cell/ +bit ;
	: (reloff) ( taddr -- ) bit$ @ swap cell/ -bit ;

	: (>image) ( taddr -- absaddr ) image @ + ;

	DEFER >image
	DEFER relon
	DEFER reloff
	DEFER correcter

	T has? relocate H
	[IF]
	' (relon) IS relon
	' (reloff) IS reloff
	' (>image) IS >image
	[ELSE]
	' drop IS relon
	' drop IS reloff
	' (>regionimage) IS >image
	[THEN]

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

Line 599 CREATE Bittable 80 c, 40 c, 20 c, 10 c,	Line 754 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
\ see kernel.fs	\ see kernel.fs
dup cfalign+ + ;	dup cfalign+ + ;

>CROSS
: >image ( taddr -- absaddr ) image @ + ;
>TARGET
: @ ( taddr -- w ) >image S@ ;	: @ ( taddr -- w ) >image S@ ;
: ! ( w taddr -- ) >image S! ;	: ! ( w taddr -- ) >image S! ;
: c@ ( taddr -- char ) >image c@ ;	: c@ ( taddr -- char ) >image Sc@ ;
: c! ( char taddr -- ) >image c! ;	: c! ( char taddr -- ) >image Sc! ;
: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;	: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
: 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;	: 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;

Line 615 CREATE Bittable 80 c, 40 c, 20 c, 10 c,	Line 767 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
: here ( -- there ) there ;	: here ( -- there ) there ;
: allot ( n -- ) tdp +! ;	: allot ( n -- ) tdp +! ;
: , ( w -- ) T here H tcell T allot ! H T here drop H ;	: , ( w -- ) T here H tcell T allot ! H T here drop H ;
: c, ( char -- ) T here 1 allot c! H ;	: c, ( char -- ) T here tchar allot c! H ;
: align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ;	: align ( -- ) T here H align+ 0 ?DO bl T c, tchar H +LOOP ;
: cfalign ( -- )	: cfalign ( -- )
T here H cfalign+ 0 ?DO bl T c, H LOOP ;	T here H cfalign+ 0 ?DO bl T c, tchar H +LOOP ;

: A! dup relon T ! H ;	: >address dup 0>= IF tbyte / THEN ; \ ?? jaw
: A, ( w -- ) T here H relon T , H ;	: A! swap >address swap dup relon T ! H ;
	: A, ( w -- ) >address T here H relon T , H ;

>CROSS	>CROSS

: tcmove ( source dest len -- )	: tcmove ( source dest len -- )
\G cmove in target memory	\G cmove in target memory
bounds	tchar * bounds
?DO dup T c@ H I T c! H 1+	?DO dup T c@ H I T c! H 1+
LOOP drop ;	tchar +LOOP drop ;

	\ \ Load Assembler

>TARGET	>TARGET
H also Forth definitions \ ." asm: " order	H also Forth definitions

: X also target bl word find	: X also target bl word find
IF state @ IF compile,	IF state @ IF compile,
Line 648 previous	Line 803 previous

\ \ -------------------- Compiler Plug Ins 01aug97jaw	\ \ -------------------- Compiler Plug Ins 01aug97jaw

	\ Compiler States

	Variable comp-state
	0 Constant interpreting
	1 Constant compiling
	2 Constant resolving
	3 Constant assembling

Defer lit, ( n -- )	Defer lit, ( n -- )
Defer alit, ( n -- )	Defer alit, ( n -- )
Defer branch, ( target-addr -- )
Defer ?branch, ( target-addr -- )	Defer branch, ( target-addr -- ) \ compiles a branch
Defer branchmark, ( -- branch-addr )	Defer ?branch, ( target-addr -- ) \ compiles a ?branch
Defer ?branchmark, ( -- branch-addr )	Defer branchmark, ( -- branch-addr ) \ reserves room for a branch
Defer branchto,	Defer ?branchmark, ( -- branch-addr ) \ reserves room for a ?branch
Defer branchtoresolve, ( branch-addr -- )	Defer ?domark, ( -- branch-addr ) \ reserves room for a ?do branch
Defer branchfrom, ( -- )	Defer branchto, ( -- ) \ actual program position is target of a branch (do e.g. alignment)
Defer branchtomark, ( -- target-addr )	Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
	Defer branchfrom, ( -- ) \ ?!
	Defer branchtomark, ( -- target-addr ) \ marks a branch destination

Defer colon, ( tcfa -- ) \ compiles call to tcfa at current position	Defer colon, ( tcfa -- ) \ compiles call to tcfa at current position
	Defer colonmark, ( -- addr ) \ marks a colon call
Defer colon-resolve ( tcfa addr -- )	Defer colon-resolve ( tcfa addr -- )

Defer addr-resolve ( target-addr addr -- )	Defer addr-resolve ( target-addr addr -- )
	Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )

	Defer do, ( -- do-token )
	Defer ?do, ( -- ?do-token )
	Defer for, ( -- for-token )
	Defer loop, ( do-token / ?do-token -- )
	Defer +loop, ( do-token / ?do-token -- )
	Defer next, ( for-token )

[IFUNDEF] ca>native	[IFUNDEF] ca>native
defer ca>native	defer ca>native
Line 671 DEFER >body \ we need the sy	Line 847 DEFER >body \ we need the sy
\ and the target >body	\ and the target >body
>CROSS	>CROSS
T 2 cells H VALUE xt>body	T 2 cells H VALUE xt>body
DEFER doprim,	DEFER doprim, \ compiles start of a primitive
DEFER docol, \ compiles start of definition and doer	DEFER docol, \ compiles start of a colon definition
DEFER doer,	DEFER doer,
DEFER fini, \ compiles end of definition ;s	DEFER fini, \ compiles end of definition ;s
DEFER doeshandler,	DEFER doeshandler,
Line 681 DEFER dodoes,	Line 857 DEFER dodoes,
DEFER ]comp \ starts compilation	DEFER ]comp \ starts compilation
DEFER comp[ \ ends compilation	DEFER comp[ \ ends compilation

: (cc) T a, H ; ' (cc) IS colon,	: (cc) T a, H ; ' (cc) IS colon,
: (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve
: (ar) T ! H ; ' (ar) IS addr-resolve	: (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve
	: (ar) T ! H ; ' (ar) IS addr-resolve
	: (dr) ( ghost res-pnt target-addr addr )
	>tempdp drop over
	dup >magic @ <do:> =
	IF doer,
	ELSE dodoes,
	THEN
	tempdp> ; ' (dr) IS doer-resolve

	: (cm) ( -- addr )
	T here align H
	-1 colon, ; ' (cm) IS colonmark,

>TARGET	>TARGET
: compile, colon, ;	: compile, colon, ;
Line 691 DEFER comp[ \ ends compilation	Line 879 DEFER comp[ \ ends compilation

\ file loading	\ file loading

	: >fl-id 1 cells + ;
	: >fl-name 2 cells + ;

Variable filelist 0 filelist !	Variable filelist 0 filelist !
0 Value loadfile	Create NoFile ," #load-file#"
	0 Value filemem
	: loadfile FileMem ?dup IF >fl-name ELSE NoFile THEN ;

0 [IF] \ !! JAW WIP	1 [IF] \ !! JAW WIP

: add-included-file ( adr len -- )	: add-included-file ( adr len -- )
dup 2 cells + allocate throw >r	dup char+ >fl-name allocate throw >r
r@ 1 cells + dup TO loadfile place	r@ >fl-name place
filelist @ r@ !	filelist @ r@ !
r> filelist ! ;	r> dup filelist ! to FileMem
	;

: included? ( c-addr u -- f )	: included? ( c-addr u -- f )
filelist	filelist
Line 711 Variable filelist 0 filelist !	Line 905 Variable filelist 0 filelist !
REPEAT	REPEAT
2drop drop false ;	2drop drop false ;

	false DebugFlag showincludedfiles

: included	: included
cr ." Including: " 2dup type ." ..."	[d?] showincludedfiles
2dup add-included-file included ;	IF cr ." Including: " 2dup type ." ..." THEN
	FileMem >r
	2dup add-included-file included
	r> to FileMem ;

: include bl word count included ;	: include bl word count included ;

Line 724 Variable filelist 0 filelist !	Line 923 Variable filelist 0 filelist !
\ resolve structure	\ resolve structure

: >next ; \ link to next field	: >next ; \ link to next field
: >tag cell+ ; \ indecates type of reference: 0: call, 1: address	: >tag cell+ ; \ indecates type of reference: 0: call, 1: address, 2: doer
: >taddr cell+ cell+ ;	: >taddr cell+ cell+ ;
: >ghost 3 cells + ;	: >ghost 3 cells + ;
: >file 4 cells + ;	: >file 4 cells + ;
: >line 5 cells + ;	: >line 5 cells + ;

	: (refered) ( ghost addr tag -- )
	\G creates a reference to ghost at address taddr
	rot >r here r@ >link @ , r> >link !
	( taddr tag ) ,
	( taddr ) ,
	last-header-ghost @ ,
	loadfile ,
	sourceline# ,
	;

: refered ( ghost tag -- )	: refered ( ghost tag -- )
\G creates a resolve structure	\G creates a resolve structure
swap >r here r@ >link @ , r@ >link ! ( tag ) ,	T here aligned H swap (refered)
T here aligned H , r> drop last-header-ghost @ ,	;
loadfile , sourceline# ,
	: killref ( addr ghost -- )
	\G kills a forward reference to ghost at position addr
	\G this is used to eleminate a :dovar refence after making a DOES>
	dup >magic @ <fwd> <> IF 2drop EXIT THEN
	swap >r >link
	BEGIN dup @ dup ( addr last this )
	WHILE dup >taddr @ r@ =
	IF @ over !
	ELSE nip THEN
	REPEAT rdrop 2drop
;	;

Defer resolve-warning	Defer resolve-warning
Line 750 Defer resolve-warning	Line 969 Defer resolve-warning

\ resolve 14oct92py	\ resolve 14oct92py

: resolve-loop ( ghost tcfa -- ghost tcfa )	: resolve-loop ( ghost resolve-list tcfa -- )
>r dup >link	>r
BEGIN @ dup WHILE	BEGIN dup WHILE
resolve-warning	\ dup >tag @ 2 = IF reswarn-forward THEN
r@ over >taddr @	resolve-warning
2 pick >tag @	r@ over >taddr @
IF addr-resolve	2 pick >tag @
ELSE colon-resolve	CASE 0 OF colon-resolve ENDOF
THEN	1 OF addr-resolve ENDOF
REPEAT drop r> ;	2 OF doer-resolve ENDOF
	ENDCASE
	@ \ next list element
	REPEAT 2drop rdrop
	;

\ : resolve-loop ( ghost tcfa -- ghost tcfa )	\ : resolve-loop ( ghost tcfa -- ghost tcfa )
\ >r dup >link @	\ >r dup >link @
Line 786 Exists-Warnings on	Line 1009 Exists-Warnings on
THEN ;	THEN ;

: resolve ( ghost tcfa -- )	: resolve ( ghost tcfa -- )
\ resolve referencies to ghost with tcfa	\G resolve referencies to ghost with tcfa
over forward? 0= IF exists EXIT THEN	\ is ghost resolved?, second resolve means another definition with the
resolve-loop over >link ! <res> swap >magic !	\ same name
['] noop IS resolve-warning	over undefined? 0= IF exists EXIT THEN
	\ get linked-list
	swap >r r@ >link @ swap \ ( list tcfa R: ghost )
	\ mark ghost as resolved
	dup r@ >link ! <res> r@ >magic !
	\ loop through forward referencies
	r> -rot
	comp-state @ >r Resolving comp-state !
	resolve-loop
	r> comp-state !

	['] noop IS resolve-warning
;	;

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

: is-forward ( ghost -- )	: is-forward ( ghost -- )
\ >link dup @ there rot ! T A, H ;	colonmark, 0 (refered) ; \ compile space for call
0 refered -1 colon, ;

: is-resolved ( ghost -- )	: is-resolved ( ghost -- )
>link @ colon, ; \ compile-call	>link @ colon, ; \ compile-call
Line 870 VARIABLE ^imm	Line 1103 VARIABLE ^imm
<imm> ^imm @ ! ;	<imm> ^imm @ ! ;
: restrict 20 flag! ;	: restrict 20 flag! ;

: isdoer <do:> last-header-ghost @ >magic ! ;	: isdoer
	\G define a forth word as doer, this makes obviously only sence on
	\G forth processors such as the PSC1000
	<do:> last-header-ghost @ >magic ! ;
>CROSS	>CROSS

\ ALIAS2 ansforth conform alias 9may93jaw	\ ALIAS2 ansforth conform alias 9may93jaw
Line 890 VARIABLE ^imm	Line 1126 VARIABLE ^imm

\ Target Document Creation (goes to crossdoc.fd) 05jul95py	\ Target Document Creation (goes to crossdoc.fd) 05jul95py

s" doc/crossdoc.fd" r/w create-file throw value doc-file-id	s" ./doc/crossdoc.fd" r/w create-file throw value doc-file-id
\ contains the file-id of the documentation file	\ contains the file-id of the documentation file

: T-\G ( -- )	: T-\G ( -- )
Line 953 Create tag-bof 1 c, 0C c,	Line 1189 Create tag-bof 1 c, 0C c,

Defer skip? ' false IS skip?	Defer skip? ' false IS skip?

	: skipdef ( <name> -- )
	\G skip definition of an undefined word in undef-words mode
	ghost dup forward?
	IF >magic <skip> swap !
	ELSE drop THEN ;

: defined? ( -- flag ) \ name	: defined? ( -- flag ) \ name
	ghost undefined? 0= ;

	: defined2? ( -- flag ) \ name
	\G return true for anything else than forward, even for <skip>
	\G that's what we want
ghost forward? 0= ;	ghost forward? 0= ;

: needed? ( -- flag ) \ name	: needed? ( -- flag ) \ name
Line 962 Defer skip? ' false IS skip?	Line 1209 Defer skip? ' false IS skip?
\G a forward reference exists	\G a forward reference exists
\G so the definition is not skipped!	\G so the definition is not skipped!
bl word gfind	bl word gfind
IF dup forward?	IF dup undefined?
nip	nip
0=	0=
ELSE drop true THEN ;	ELSE drop true THEN ;
Line 975 Defer skip? ' false IS skip?	Line 1222 Defer skip? ' false IS skip?

\ Target header creation	\ Target header creation

	Variable CreateFlag
	CreateFlag off

VARIABLE CreateFlag CreateFlag off	Variable NoHeaderFlag
	NoHeaderFlag off

: 0.r ( n1 n2 -- ) 0 swap <# 0 ?DO # LOOP #> type ;	: 0.r ( n1 n2 -- )
	base @ >r hex
	0 swap <# 0 ?DO # LOOP #> type
	r> base ! ;
: .sym	: .sym
bounds	bounds
DO I c@ dup	DO I c@ dup
Line 986 VARIABLE CreateFlag CreateFlag off	Line 1239 VARIABLE CreateFlag CreateFlag off
'\ OF drop ." \\" ENDOF	'\ OF drop ." \\" ENDOF
dup OF emit ENDOF	dup OF emit ENDOF
ENDCASE	ENDCASE
LOOP ;	LOOP ;

: (Theader ( "name" -- ghost )	: (Theader ( "name" -- ghost )
\ >in @ bl word count type 2 spaces >in !	\ >in @ bl word count type 2 spaces >in !
\ wordheaders will always be compiled to rom	\ wordheaders will always be compiled to rom
switchrom	switchrom
T align H view,	\ build header in target
tlast @ dup 0> IF T 1 cells - THEN A, H there tlast !	NoHeaderFlag @
1 headers-named +! \ Statistic	IF NoHeaderFlag off
>in @ T name, H >in ! T here H tlastcfa !	ELSE
\ Symbol table	T align H view,
\ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in !	tlast @ dup 0> IF T 1 cells - H THEN T A, H there tlast !
CreateFlag @ IF	1 headers-named +! \ Statistic
>in @ alias2 swap >in ! \ create alias in target	>in @ T name, H >in !
>in @ ghost swap >in !	THEN
swap also ghosts ' previous swap ! \ tick ghost and store in alias	T cfalign here H tlastcfa !
CreateFlag off	\ Symbol table
ELSE ghost THEN	\ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in !
dup Last-Header-Ghost !	CreateFlag @
dup >magic ^imm ! \ a pointer for immediate	IF \ for a created word we need also a definition in target
Already @ IF dup >end tdoes !	\ to execute the created word while compile time
ELSE 0 tdoes ! THEN	\ dont mind if a alias is defined twice
80 flag!	Warnings @ >r Warnings off
cross-doc-entry cross-tag-entry ;	>in @ alias2 swap >in ! \ create alias in target
	r> Warnings !
	>in @ ghost swap >in !
	swap also ghosts ' previous swap ! \ tick ghost and store in alias
	CreateFlag off
	ELSE ghost
	THEN
	dup Last-Header-Ghost !
	dup >magic ^imm ! \ a pointer for immediate
	Already @
	IF dup >end tdoes !
	ELSE 0 tdoes !
	THEN
	80 flag!
	cross-doc-entry cross-tag-entry ;

VARIABLE ;Resolve 1 cells allot	VARIABLE ;Resolve 1 cells allot
\ this is the resolver information from ":"	\ this is the resolver information from ":"
Line 1033 VARIABLE ;Resolve 1 cells allot	Line 1300 VARIABLE ;Resolve 1 cells allot
.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 <do:> swap >magic ! ;

	Variable prim#
	: first-primitive ( n -- ) prim# ! ;
	: Primitive ( -- ) \ name
	prim# @ T Alias H -1 prim# +! ;
>CROSS	>CROSS

\ Conditionals and Comments 11may93jaw	\ Conditionals and Comments 11may93jaw
Line 1074 Comment ( Comment \	Line 1346 Comment ( Comment \
THEN ; immediate	THEN ; immediate

: ghost>cfa	: ghost>cfa
dup forward? ABORT" CROSS: forward " >link @ ;	dup undefined? ABORT" CROSS: forward " >link @ ;

>TARGET	>TARGET

Line 1095 Cond: ['] T ' H alit, ;Cond	Line 1367 Cond: ['] T ' H alit, ;Cond
\ modularized 14jun97jaw	\ modularized 14jun97jaw

: fillcfa ( usedcells -- )	: fillcfa ( usedcells -- )
T cells H xt>body swap - 0 ?DO 0 T c, H LOOP ;	T cells H xt>body swap - 0 ?DO 0 T c, tchar H +LOOP ;

: (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H	: (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H

Line 1116 Cond: ['] T ' H alit, ;Cond	Line 1388 Cond: ['] T ' H alit, ;Cond

: (lit,) ( n -- ) compile lit T , H ; ' (lit,) IS lit,	: (lit,) ( n -- ) compile lit T , H ; ' (lit,) IS lit,

: (alit,) ( n -- ) lit, T here cell - H relon ; ' (alit,) IS alit,	\ if we dont produce relocatable code alit, defaults to lit, jaw
	has? relocate
	[IF]
	: (alit,) ( n -- ) compile lit T a, H ; ' (alit,) IS alit,
	[ELSE]
	: (alit,) ( n -- ) lit, ; ' (alit,) IS alit,
	[THEN]

: (fini,) compile ;s ; ' (fini,) IS fini,	: (fini,) compile ;s ; ' (fini,) IS fini,

Line 1145 Defer (end-code)	Line 1423 Defer (end-code)
ELSE true ABORT" CROSS: Stack empty" THEN	ELSE true ABORT" CROSS: Stack empty" THEN
;	;

Cond: chars ;Cond	( Cond ) : chars tchar * ; ( Cond )

>CROSS	>CROSS

Line 1210 Cond: MAXI	Line 1488 Cond: MAXI
\ ] 9may93py/jaw	\ ] 9may93py/jaw

: ] state on	: ] state on
	Compiling comp-state !
BEGIN	BEGIN
BEGIN >in @ bl word	BEGIN >in @ bl word
dup c@ 0= WHILE 2drop refill 0=	dup c@ 0= WHILE 2drop refill 0=
Line 1254 Cond: ; ( -- ) restrict?	Line 1533 Cond: ; ( -- ) restrict?
state off	state off
;Resolve @	;Resolve @
IF ;Resolve @ ;Resolve cell+ @ resolve THEN	IF ;Resolve @ ;Resolve cell+ @ resolve THEN
	Interpreting comp-state !
;Cond	;Cond
Cond: [ restrict? state off ;Cond	Cond: [ restrict? state off Interpreting comp-state ! ;Cond

>CROSS	>CROSS

	Create GhostDummy ghostheader
	<res> GhostDummy >magic !

: !does ( does-action -- )	: !does ( does-action -- )
\ !! zusammenziehen und dodoes, machen!	\ !! zusammenziehen und dodoes, machen!
tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;	tlastcfa @ [G'] :dovar killref
	\ tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
\ !! geht so nicht, da dodoes, ghost will!	\ !! geht so nicht, da dodoes, ghost will!
\ tlastcfa @ >tempdp dodoes, tempdp> ;	GhostDummy >link ! GhostDummy
	tlastcfa @ >tempdp dodoes, tempdp> ;

>TARGET	>TARGET
Cond: DOES> restrict?	Cond: DOES> restrict?
Line 1284 Cond: DOES> restrict?	Line 1570 Cond: DOES> restrict?
\ for do:-xt an additional entry after the normal ghost-enrys is used	\ for do:-xt an additional entry after the normal ghost-enrys is used

>in @ alias2 swap dup >in ! >r >r	>in @ alias2 swap dup >in ! >r >r
Make-Ghost rot swap >exec ! ,	Make-Ghost
	rot swap >exec dup @ ['] NoExec <>
	IF 2drop ELSE ! THEN
	,
r> r> >in !	r> r> >in !
also ghosts ' previous swap ! ;	also ghosts ' previous swap ! ;
\ DOES> dup >exec @ execute ;	\ DOES> dup >exec @ execute ;

: gdoes, ( ghost -- )	: gdoes, ( ghost -- )
\ makes the codefield for a word that is built	\ makes the codefield for a word that is built
>end @ dup forward? 0=	>end @ dup undefined? 0=
IF	IF
dup >magic @ <do:> =	dup >magic @ <do:> =
IF doer, EXIT THEN	IF doer,
	ELSE dodoes,
	THEN
	EXIT
THEN	THEN
\ compile :dodoes gexecute	\ compile :dodoes gexecute
\ T here H tcell - reloff	\ T here H tcell - reloff
dodoes,	2 refered
;	0 fillcfa
	;

: TCreate ( <name> -- )	: TCreate ( <name> -- )
executed-ghost @	executed-ghost @
Line 1384 by: :dovar ( ghost -- addr ) ;DO	Line 1677 by: :dovar ( ghost -- addr ) ;DO
Builder Create	Builder Create

T has? rom H [IF]	T has? rom H [IF]
Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;	Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
by (Constant)	by (Constant)
Builder Variable	Builder Variable
[ELSE]	[ELSE]
Line 1394 Builder Variable	Line 1687 Builder Variable
[THEN]	[THEN]

T has? rom H [IF]	T has? rom H [IF]
Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;	Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;
	by (Constant)
	Builder 2Variable
	[ELSE]
	Build: T 0 , 0 , H ;
	by Create
	Builder 2Variable
	[THEN]

	T has? rom H [IF]
	Build: ( -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
by (Constant)	by (Constant)
Builder AVariable	Builder AVariable
[ELSE]	[ELSE]
Line 1471 Builder Field	Line 1774 Builder Field
\ ' 2Constant Alias2 end-struct	\ ' 2Constant Alias2 end-struct
\ 0 1 T Chars H 2Constant struct	\ 0 1 T Chars H 2Constant struct

0 [IF]

\ structural conditionals 17dec92py	\ structural conditionals 17dec92py

>CROSS	>CROSS
Line 1480 Builder Field	Line 1781 Builder Field
: sys? ( sys -- sys ) dup 0= ?struc ;	: sys? ( sys -- sys ) dup 0= ?struc ;
: >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ;	: >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ;

: branchoffset ( src dest -- ) - ;	: branchoffset ( src dest -- ) - tchar / ; \ ?? jaw
: >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ;
: <resolve ( sys -- ) T here ( dup ." <" hex. ) branchoffset , H ;
>TARGET

\ Structural Conditionals 12dec92py

Cond: BUT restrict? sys? swap ;Cond
Cond: YET restrict? sys? dup ;Cond

>CROSS
Variable tleavings
>TARGET

Cond: DONE ( addr -- ) restrict? tleavings @
BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT
tleavings ! drop ;Cond

>CROSS
: (leave T here H tleavings @ T , H tleavings ! ;
>TARGET

Cond: LEAVE restrict? compile branch (leave ;Cond
Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond

\ Structural Conditionals 12dec92py

Cond: AHEAD restrict? compile branch >mark ;Cond
Cond: IF restrict? compile ?branch >mark ;Cond
Cond: THEN restrict? sys? branchto, dup T @ H ?struc >resolve ;Cond
Cond: ELSE restrict? sys? compile AHEAD swap compile THEN ;Cond

Cond: BEGIN restrict? T branchto, here ( dup ." B" hex. ) H ;Cond
Cond: WHILE restrict? sys? compile IF swap ;Cond
Cond: AGAIN restrict? sys? compile branch <resolve ;Cond
Cond: UNTIL restrict? sys? compile ?branch <resolve ;Cond
Cond: REPEAT restrict? over 0= ?struc compile AGAIN compile THEN ;Cond

Cond: CASE restrict? 0 ;Cond
Cond: OF restrict? 1+ >r compile over compile =
compile IF compile drop r> ;Cond
Cond: ENDOF restrict? >r compile ELSE r> ;Cond
Cond: ENDCASE restrict? compile drop 0 ?DO compile THEN LOOP ;Cond

\ Structural Conditionals 12dec92py

Cond: DO restrict? compile (do) T here H ;Cond
Cond: ?DO restrict? compile (?do) T (leave here H ;Cond
Cond: FOR restrict? compile (for) T here H ;Cond

>CROSS
: loop] dup <resolve tcell - compile DONE compile unloop ;
>TARGET

Cond: LOOP restrict? sys? compile (loop) loop] ;Cond
Cond: +LOOP restrict? sys? compile (+loop) loop] ;Cond
Cond: NEXT restrict? sys? compile (next) loop] ;Cond

[ELSE]

\ structural conditionals 17dec92py

>CROSS
: ?struc ( flag -- ) ABORT" CROSS: unstructured " ;
: sys? ( sys -- sys ) dup 0= ?struc ;
: >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ;

: branchoffset ( src dest -- ) - ;

: >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ;	: >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ;

: <resolve ( sys -- ) T here ( dup ." <" hex. ) branchoffset , H ;	: <resolve ( sys -- ) T here ( dup ." <" hex. ) branchoffset , H ;

:noname compile branch T here branchoffset , H ; IS branch,	:noname compile branch T here branchoffset , H ;
:noname compile ?branch T here branchoffset , H ; IS ?branch,	IS branch, ( target-addr -- )
:noname compile branch T here 0 , H ; IS branchmark,	:noname compile ?branch T here branchoffset , H ;
:noname compile ?branch T here 0 , H ; IS ?branchmark,	IS ?branch, ( target-addr -- )
:noname dup T @ H ?struc T here over branchoffset swap ! H ; IS branchtoresolve,	:noname compile branch T here 0 , H ;
:noname branchto, T here H ; IS branchtomark,	IS branchmark, ( -- branchtoken )
	:noname compile ?branch T here 0 , H ;
	IS ?branchmark, ( -- branchtoken )
	:noname T here 0 , H ;
	IS ?domark, ( -- branchtoken )
	:noname dup T @ H ?struc T here over branchoffset swap ! H ;
	IS branchtoresolve, ( branchtoken -- )
	:noname branchto, T here H ;
	IS branchtomark, ( -- target-addr )

>TARGET	>TARGET

Line 1567 Cond: NEXT restrict? sys? compile (	Line 1809 Cond: NEXT restrict? sys? compile (
Cond: BUT restrict? sys? swap ;Cond	Cond: BUT restrict? sys? swap ;Cond
Cond: YET restrict? sys? dup ;Cond	Cond: YET restrict? sys? dup ;Cond

1 [IF]	0 [IF]
>CROSS	>CROSS
Variable tleavings	Variable tleavings
>TARGET	>TARGET
Line 1577 Cond: DONE ( addr -- ) restrict? tlea	Line 1819 Cond: DONE ( addr -- ) restrict? tlea
tleavings ! drop ;Cond	tleavings ! drop ;Cond

>CROSS	>CROSS
: (leave T here H tleavings @ T , H tleavings ! ;	: (leave) T here H tleavings @ T , H tleavings ! ;
>TARGET	>TARGET

Cond: LEAVE restrict? compile branch (leave ;Cond	Cond: LEAVE restrict? compile branch (leave) ;Cond
Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond	Cond: ?LEAVE restrict? compile 0= compile ?branch (leave) ;Cond

[ELSE]	[ELSE]
\ !! This is WIP	\ !! This is WIP
Line 1590 Cond: ?LEAVE restrict? compile 0= co	Line 1832 Cond: ?LEAVE restrict? compile 0= co

>CROSS	>CROSS
Variable tleavings 0 tleavings !	Variable tleavings 0 tleavings !
	: (done) ( addr -- )
	tleavings @
	BEGIN dup
	WHILE
	>r dup r@ cell+ @ \ address of branch
	u> 0= \ lower than DO?
	WHILE
	r@ 2 cells + @ \ branch token
	branchtoresolve,
	r@ @ r> free throw
	REPEAT r> THEN
	tleavings ! drop ;

>TARGET	>TARGET

Cond: DONE ( addr -- )	Cond: DONE ( addr -- ) restrict? (done) ;Cond
restrict? tleavings @
BEGIN dup
WHILE >r dup r@ cell+ @ \ address of branch
u> 0= \ lower than DO?
WHILE r@ 2 cells + @ \ branch token
branchtoresolve,
r@ @ r> free throw
REPEAT drop r>
THEN
tleavings ! drop ;Cond

>CROSS	>CROSS
: (leave ( branchtoken -- )	: (leave) ( branchtoken -- )
3 cells allocate throw >r	3 cells allocate throw >r
T here H r@ cell+ !	T here H r@ cell+ !
r@ 2 cells + !	r@ 2 cells + !
Line 1613 Cond: DONE ( addr -- )	Line 1858 Cond: DONE ( addr -- )
r> tleavings ! ;	r> tleavings ! ;
>TARGET	>TARGET

Cond: LEAVE restrict? branchmark, (leave ;Cond	Cond: LEAVE restrict? branchmark, (leave) ;Cond
Cond: ?LEAVE restrict? compile 0= ?branchmark, (leave ;Cond	Cond: ?LEAVE restrict? compile 0= ?branchmark, (leave) ;Cond

[THEN]	[THEN]

	>CROSS
	\ !!JW ToDo : Move to general tools section

	: to1 ( x1 x2 xn n -- addr )
	\G packs n stack elements in a allocated memory region
	dup dup 1+ cells allocate throw dup >r swap 1+
	0 DO tuck ! cell+ LOOP
	drop r> ;
	: 1to ( addr -- x1 x2 xn )
	\G unpacks the elements saved by to1
	dup @ swap over cells + swap
	0 DO dup @ swap 1 cells - LOOP
	free throw ;

	: loop] branchto, dup <resolve tcell - (done) ;

	: skiploop] ?dup IF branchto, branchtoresolve, THEN ;

	>TARGET

\ Structural Conditionals 12dec92py	\ Structural Conditionals 12dec92py

>TARGET	>TARGET
Line 1640 Cond: ENDCASE restrict? compile drop 0	Line 1905 Cond: ENDCASE restrict? compile drop 0

\ Structural Conditionals 12dec92py	\ Structural Conditionals 12dec92py

Cond: DO restrict? compile (do) T here H ;Cond	:noname \ ?? i think 0 is too much! jaw
Cond: ?DO restrict? compile (?do) T (leave here H ;Cond	0 compile (do)
Cond: FOR restrict? compile (for) T here H ;Cond	branchtomark, 2 to1 ;
	IS do, ( -- target-addr )
>CROSS
: loop] branchto, dup <resolve tcell - compile DONE compile unloop ;	\ :noname
>TARGET	\ compile 2dup compile = compile IF
	\ compile 2drop compile ELSE
Cond: LOOP restrict? sys? compile (loop) loop] ;Cond	\ compile (do) branchtomark, 2 to1 ;
Cond: +LOOP restrict? sys? compile (+loop) loop] ;Cond	\ IS ?do,
Cond: NEXT restrict? sys? compile (next) loop] ;Cond
	:noname
[THEN]	0 compile (?do) ?domark, (leave)
	branchtomark, 2 to1 ;
	IS ?do, ( -- target-addr )
	:noname compile (for) branchtomark, ;
	IS for, ( -- target-addr )
	:noname 1to compile (loop) loop] compile unloop skiploop] ;
	IS loop, ( target-addr -- )
	:noname 1to compile (+loop) loop] compile unloop skiploop] ;
	IS +loop, ( target-addr -- )
	:noname compile (next) loop] compile unloop ;
	IS next, ( target-addr -- )

	Cond: DO restrict? do, ;Cond
	Cond: ?DO restrict? ?do, ;Cond
	Cond: FOR restrict? for, ;Cond

	Cond: LOOP restrict? sys? loop, ;Cond
	Cond: +LOOP restrict? sys? +loop, ;Cond
	Cond: NEXT restrict? sys? next, ;Cond

\ String words 23feb93py	\ String words 23feb93py

Line 1663 Cond: S" restrict? compile (S")	Line 1946 Cond: S" restrict? compile (S")
Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond	Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond

Cond: IS T ' >body H compile ALiteral compile ! ;Cond	Cond: IS T ' >body H compile ALiteral compile ! ;Cond
: IS T ' >body ! H ;	: IS T >address ' >body ! H ;
Cond: TO T ' >body H compile ALiteral compile ! ;Cond	Cond: TO T ' >body H compile ALiteral compile ! ;Cond
: TO T ' >body ! H ;	: TO T ' >body ! H ;

Line 1694 Cond: compile ( -- ) restrict? \ name	Line 1977 Cond: compile ( -- ) restrict? \ name
0> IF gexecute	0> IF gexecute
ELSE dup >magic @ <imm> =	ELSE dup >magic @ <imm> =
IF gexecute	IF gexecute
ELSE compile (compile) gexecute THEN THEN ;Cond	ELSE compile (compile) addr, THEN THEN ;Cond

Cond: postpone ( -- ) restrict? \ name	Cond: postpone ( -- ) restrict? \ name
bl word gfind dup 0= ABORT" CROSS: Can't compile"	bl word gfind dup 0= ABORT" CROSS: Can't compile"
0> IF gexecute	0> IF gexecute
ELSE dup >magic @ <imm> =	ELSE dup >magic @ <imm> =
IF gexecute	IF gexecute
ELSE compile (compile) gexecute THEN THEN ;Cond	ELSE compile (compile) addr, THEN THEN ;Cond

	\ \ minimal definitions

>MINIMAL	>MINIMAL
also minimal	also minimal
\ Usefull words 13feb93py	\ Usefull words 13feb93py

: KB 400 * ;	: KB 400 * ;

	\ \ [IF] [ELSE] [THEN] ... 14sep97jaw

	\ it is useful to define our own structures and not to rely
	\ on the words in the compiler
	\ The words in the compiler might be defined with vocabularies
	\ this doesn't work with our self-made compile-loop

	Create parsed 20 chars allot \ store word we parsed

	: upcase
	parsed count bounds
	?DO I c@ toupper I c! LOOP ;

	: [ELSE]
	1 BEGIN
	BEGIN bl word count dup WHILE
	comment? parsed place upcase parsed count
	2dup s" [IF]" compare 0= >r
	2dup s" [IFUNDEF]" compare 0= >r
	2dup s" [IFDEF]" compare 0= r> or r> or
	IF 2drop 1+
	ELSE 2dup s" [ELSE]" compare 0=
	IF 2drop 1- dup
	IF 1+
	THEN
	ELSE
	2dup s" [ENDIF]" compare 0= >r
	s" [THEN]" compare 0= r> or
	IF 1- THEN
	THEN
	THEN
	?dup 0= ?EXIT
	REPEAT
	2drop refill 0=
	UNTIL drop ; immediate

	: [THEN] ( -- ) ; immediate

	: [ENDIF] ( -- ) ; immediate

	: [IF] ( flag -- )
	0= IF postpone [ELSE] THEN ; immediate

	Cond: [IF] postpone [IF] ;Cond
	Cond: [THEN] postpone [THEN] ;Cond
	Cond: [ELSE] postpone [ELSE] ;Cond

\ define new [IFDEF] and [IFUNDEF] 20may93jaw	\ define new [IFDEF] and [IFUNDEF] 20may93jaw

: defined? defined? ;	: defined? defined? ;
Line 1727 also minimal	Line 2059 also minimal

: [IFUNDEF] defined? 0= postpone [IF] ;	: [IFUNDEF] defined? 0= postpone [IF] ;

	Cond: [IFDEF] postpone [IFDEF] ;Cond

	Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond

\ C: \- \+ Conditional Compiling 09jun93jaw	\ C: \- \+ Conditional Compiling 09jun93jaw

: C: >in @ defined? 0=	: C: >in @ defined? 0=
Line 1741 also minimal	Line 2077 also minimal

also minimal	also minimal

\G doesn't skip line when bit is set in debugmask	: d? d? ;
: \D name evaluate debugmasksource @ and 0= IF postpone \ THEN ;
	\G doesn't skip line when debug switch is on
	: \D D? 0= IF postpone \ THEN ;

\G interprets the line if word is not defined	\G interprets the line if word is not defined
: \- defined? IF postpone \ THEN ;	: \- defined? IF postpone \ THEN ;
Line 1760 Cond: \D \D ;Cond	Line 2098 Cond: \D \D ;Cond
\G defines ghost for words that we want to be compiled	\G defines ghost for words that we want to be compiled
BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;	BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;

: [IF] postpone [IF] ;
: [THEN] postpone [THEN] ;
: [ELSE] postpone [ELSE] ;

Cond: [IF] [IF] ;Cond
Cond: [IFDEF] [IFDEF] ;Cond
Cond: [IFUNDEF] [IFUNDEF] ;Cond
Cond: [THEN] [THEN] ;Cond
Cond: [ELSE] [ELSE] ;Cond

previous	previous

\ save-cross 17mar93py	\ save-cross 17mar93py

>CROSS	>CROSS
Create magic s" Gforth10" here over allot swap move	Create magic s" Gforth2x" here over allot swap move

char 1 bigendian + tcell + magic 7 + c!	bigendian 1+ \ strangely, in magic big=0, little=1
	tcell 1 = 0 and or
	tcell 2 = 2 and or
	tcell 4 = 4 and or
	tcell 8 = 6 and or
	tchar 1 = $00 and or
	tchar 2 = $28 and or
	tchar 4 = $50 and or
	tchar 8 = $78 and or
	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
Line 1806 char 1 bigendian + tcell + magic 7 + c!	Line 2143 char 1 bigendian + tcell + magic 7 + c!

: save-region ( addr len -- )	: save-region ( addr len -- )
bl parse w/o bin create-file throw >r	bl parse w/o bin create-file throw >r
swap image @ + swap r@ write-file throw	swap >image swap r@ write-file throw
r> close-file throw ;	r> close-file throw ;

\ words that should be in minimal	\ words that should be in minimal
Line 1818 also minimal	Line 2155 also minimal

bigendian Constant bigendian	bigendian Constant bigendian
: here there ;	: here there ;
	: equ constant ;
	: mark there constant ;

	\ compiler directives
: >ram >ram ;	: >ram >ram ;
: >rom >rom ;	: >rom >rom ;
: >auto >auto ;	: >auto >auto ;
Line 1825 bigendian Constant bigendian	Line 2166 bigendian Constant bigendian
: tempdp> tempdp> ;	: tempdp> tempdp> ;
: const constflag on ;	: const constflag on ;
: warnings name 3 = 0= twarnings ! drop ;	: warnings name 3 = 0= twarnings ! drop ;
	: \| ;
	\ : \| NoHeaderFlag on ; \ This is broken (damages the last word)

: save-cross save-cross ;	: save-cross save-cross ;
: save-region save-region ;	: save-region save-region ;
Line 1862 previous	Line 2204 previous

: all-words ['] false IS skip? ;	: all-words ['] false IS skip? ;
: needed-words ['] needed? IS skip? ;	: needed-words ['] needed? IS skip? ;
: undef-words ['] defined? IS skip? ;	: undef-words ['] defined2? IS skip? ;
	: skipdef skipdef ;

: \ postpone \ ; immediate	: \ postpone \ ; immediate
: \G T-\G ; immediate	: \G T-\G ; immediate
Line 1908 minimal	Line 2251 minimal
\ these ones are pefered:	\ these ones are pefered:

: lock turnkey ;	: lock turnkey ;
: unlock forth also cross ;	: unlock previous forth also cross ;

: [[ also unlock ;	: [[ also unlock ;
: ]] previous previous ;	: ]] previous previous ;

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

Removed from v.1.53
changed lines
	Added in v.1.76