gforth/cross.fs - diff

Return to cross.fs CVS log

Up to [gforth] / gforth

Diff for /gforth/cross.fs between versions 1.103 and 1.121

version 1.103, 2001/09/04 13:06:06	version 1.121, 2002/03/19 18:07:55
Line 23	Line 23
[IF]	[IF]

ToDo:	ToDo:
Crossdoc destination ./doc/crossdoc.fd makes no sense when	- Crossdoc destination ./doc/crossdoc.fd makes no sense when
cross.fs is uses 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
Clean up mark> and >resolve stuff jaw	- MAXU etc. can be done with dlit,

[THEN]	[THEN]

Line 62 forth definitions	Line 62 forth definitions
: T previous Ghosts also Target ; immediate	: T previous Ghosts also Target ; immediate
: G Ghosts ; immediate	: G Ghosts ; immediate


: >cross also Cross definitions previous ;	: >cross also Cross definitions previous ;
: >target also Target definitions previous ;	: >target also Target definitions previous ;
: >minimal also Minimal definitions previous ;	: >minimal also Minimal definitions previous ;
Line 201 Create bases 10 , 2 , A , 100 ,	Line 202 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 241 hex \ the defualt base for the cross	Line 249 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 ( -- <name> )
	\G The next word in the input is a target word.
	\G Equivalent to T <name> but without permanent
	\G switch to target dictionary. Used as prefix e.g. for @, !, here etc.
	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:

\ debugging	\ debugging
Line 628 stack-warn [IF]	Line 647 stack-warn [IF]
: defempty? ; immediate	: defempty? ; immediate
[THEN]	[THEN]

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

	>CROSS

	\ Compiler States

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

	: compiling? comp-state @ compiling = ;

	: pi-undefined -1 ABORT" Plugin undefined" ;

	: Plugin ( -- : pluginname )
	Create
	\ for normal cross-compiling only one action
	\ exists, this fields are identical. For the instant
	\ simulation environment we need, two actions for each plugin
	\ the target one and the one that generates the simulation code
	['] pi-undefined , \ action
	['] pi-undefined , \ target plugin action
	8765 , \ plugin magic
	DOES> perform ;

	Plugin DummyPlugin

	: 'PI ( -- addr : pluginname )
	' >body dup 2 cells + @ 8765 <> ABORT" not a plugin" ;

	: plugin-of ( xt -- : pluginname )
	dup 'PI 2! ;

	: action-of ( xt -- : plunginname )
	'PI cell+ ! ;

	: TPA ( -- : plugin )
	\ target plugin action
	\ executes current target action of plugin
	'PI cell+ POSTPONE literal POSTPONE perform ; immediate

	Variable ppi-temp 0 ppi-temp !

	: pa:
	\g define plugin action
	ppi-temp @ ABORT" pa: definition not closed"
	'PI ppi-temp ! :noname ;

	: ;pa
	\g end a definition for plugin action
	POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate


	Plugin dlit, ( d -- ) \ compile numerical value the target
	Plugin lit, ( n -- )
	Plugin alit, ( n -- )

	Plugin branch, ( target-addr -- ) \ compiles a branch
	Plugin ?branch, ( target-addr -- ) \ compiles a ?branch
	Plugin branchmark, ( -- branch-addr ) \ reserves room for a branch
	Plugin ?branchmark, ( -- branch-addr ) \ reserves room for a ?branch
	Plugin ?domark, ( -- branch-addr ) \ reserves room for a ?do branch
	Plugin branchto, ( -- ) \ actual program position is target of a branch (do e.g. alignment)
	' NOOP plugin-of branchto,
	Plugin branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
	Plugin branchtomark, ( -- target-addr ) \ marks a branch destination

	Plugin colon, ( tcfa -- ) \ compiles call to tcfa at current position
	Plugin prim, ( tcfa -- ) \ compiles primitive invocation
	Plugin colonmark, ( -- addr ) \ marks a colon call
	Plugin colon-resolve ( tcfa addr -- )

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

	Plugin ncontrols? ( [ xn ... x1 ] n -- ) \ checks wheter n control structures are open
	Plugin if, ( -- if-token )
	Plugin else, ( if-token -- if-token )
	Plugin then, ( if-token -- )
	Plugin ahead,
	Plugin begin,
	Plugin while,
	Plugin until,
	Plugin again,
	Plugin repeat,
	Plugin cs-swap ( x1 x2 -- x2 x1 )

	Plugin case, ( -- n )
	Plugin of, ( n -- x1 n )
	Plugin endof, ( x1 n -- x2 n )
	Plugin endcase, ( x1 .. xn n -- )

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

	Plugin ca>native \ Convert a code address to the processors
	\ native address. This is used in doprim, and
	\ 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 docol, \ compiles start of a colon definition
	Plugin doer,
	Plugin fini, \ compiles end of definition ;s
	Plugin doeshandler,
	Plugin dodoes,

	Plugin colon-start
	' noop plugin-of colon-start
	Plugin colon-end
	' noop plugin-of colon-end

	Plugin ]comp \ starts compilation
	' noop plugin-of ]comp
	Plugin comp[ \ ends compilation
	' noop plugin-of comp[

	Plugin t>body \ we need the system >body
	\ and the target >body

	>TARGET
	: >body t>body ;


\ Ghost Builder 06oct92py	\ Ghost Builder 06oct92py

	>CROSS
hex	hex
	\ Values for ghost magic
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>	4715 Constant <skip>

	\ Bitmask for ghost flags
1 Constant <unique>	1 Constant <unique>
	2 Constant <primitive>

	\ FXIME: move this to general stuff?
	: set-flag ( addr flag -- )
	over @ or swap ! ;

	: reset-flag ( addr flag -- )
	invert over @ and swap ! ;

	: get-flag ( addr flag -- f )
	swap @ and 0<> ;


Struct	Struct

Line 649 Struct	Line 819 Struct
\ points to the where we have to resolve (linked-list)	\ points to the where we have to resolve (linked-list)
cell% field >link	cell% field >link

\ execution symantics (while target compiling) of ghost	\ execution semantics (while target compiling) of ghost
cell% field >exec	cell% field >exec

	\ compilation action of this ghost; this is what is
	\ done to compile a call (or whatever) to this definition.
	\ E.g. >comp contains the semantic of postpone s"
	\ whereas >exec-compile contains the semantic of s"
	cell% field >comp

	\ Compilation sematics (while parsing) of this ghost. E.g.
	\ "\" will skip the rest of line.
	\ These semantics are defined by Cond: and
	\ if a word is made immediate in instant, then the >exec2 field
	\ gets copied to here
cell% field >exec-compile	cell% field >exec-compile

	\ Additional execution semantics of this ghost. This is used
	\ for code generated by instant and for the doer-xt of created
	\ words
cell% field >exec2	cell% field >exec2

cell% field >created	cell% field >created
Line 711 Variable cross-space-dp-orig	Line 895 Variable cross-space-dp-orig
cross-space-end u> ABORT" CROSS: cross-space overflow"	cross-space-end u> ABORT" CROSS: cross-space overflow"
cross-space-dp-orig @ dp ! ;	cross-space-dp-orig @ dp ! ;

	\ this is just for debugging, to see this in the backtrace
: execute-exec execute ;	: execute-exec execute ;
: execute-exec2 execute ;	: execute-exec2 execute ;
: execute-exec-compile execute ;	: execute-exec-compile execute ;
Line 722 Variable cross-space-dp-orig	Line 907 Variable cross-space-dp-orig
ELSE true ABORT" CROSS: Don't execute ghost, or immediate target word"	ELSE true ABORT" CROSS: Don't execute ghost, or immediate target word"
THEN ;	THEN ;

	Defer is-forward

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

: ghostheader ( -- ) (ghostheader) 0 , ;	: ghostheader ( -- ) (ghostheader) 0 , ;

Line 783 Defer search-ghosts	Line 971 Defer search-ghosts
REPEAT	REPEAT
drop r> false ;	drop r> false ;

	: xt>ghost ( xt -- ghost )
	gdiscover 0= ABORT" CROSS: ghost not found for this xt" ;

: Ghost ( "name" -- ghost )	: Ghost ( "name" -- ghost )
>in @ bl word gfind IF nip EXIT THEN	>in @ bl word gfind IF nip EXIT THEN
drop >in ! Make-Ghost ;	drop >in ! Make-Ghost ;
Line 812 Exists-Warnings on	Line 1003 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 829 Variable reuse-ghosts reuse-ghosts off	Line 1019 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

: ghost>cfa ( ghost -- cfa )	: g>xt ( ghost -- xt )
	\G Returns the xt (cfa) of a ghost. Issues a warning if undefined.
dup undefined? ABORT" CROSS: forward " >link @ ;	dup undefined? ABORT" CROSS: forward " >link @ ;

	: g>body ( ghost -- body )
	\G Returns the body-address (pfa) of a ghost.
	\G Issues a warning if undefined (a forward-reference).
	g>xt X >body ;

1 Constant <label>	1 Constant <label>

Struct	Struct
Line 864 End-Struct addr-struct	Line 1061 End-Struct addr-struct
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 useraddr drop
	Ghost execute drop
	Ghost + drop
	Ghost decimal drop
	Ghost hex drop
	Ghost lit@ drop
	Ghost lit-perform drop
	Ghost lit+ drop
	Ghost does-exec drop

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

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


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

Line 951 false DefaultValue dcomps	Line 1154 false DefaultValue dcomps
false DefaultValue hash	false DefaultValue hash
false DefaultValue xconds	false DefaultValue xconds
false DefaultValue header	false DefaultValue header
	false DefaultValue backtrace
	false DefaultValue new-input
	false DefaultValue peephole
[THEN]	[THEN]

true DefaultValue interpreter	true DefaultValue interpreter
Line 962 true DefaultValue standardthreading	Line 1168 true DefaultValue standardthreading
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 1022 Variable user-vars 0 user-vars !	Line 1231 Variable user-vars 0 user-vars !
: target>bitmask-size ( u1 -- u2 )	: target>bitmask-size ( u1 -- u2 )
1- tcell>bit rshift 1+ ;	1- tcell>bit rshift 1+ ;

: allocatetarget ( size --- adr )	: allocatetarget ( size -- adr )
dup allocate ABORT" CROSS: No memory for target"	dup allocate ABORT" CROSS: No memory for target"
swap over swap erase ;	swap over swap erase ;

Line 1044 Variable mirrored-link \ linked	Line 1253 Variable mirrored-link \ linked
: >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 -- )
\G create a new region	\G create a new region
Line 1057 Variable mirrored-link \ linked	Line 1270 Variable mirrored-link \ linked
region-link linked 0 , 0 , 0 , bl word count string,	region-link linked 0 , 0 , 0 , bl word count string,
ELSE \ store new parameters in region	ELSE \ store new parameters in region
bl word drop	bl word drop
>body >r r@ last-defined-region !	>body (region)
r@ >rlen ! dup r@ >rstart ! r> >rdp !
THEN ;	THEN ;

: borders ( region -- startaddr endaddr )	: borders ( region -- startaddr endaddr )
Line 1134 T has? rom H	Line 1346 T has? rom H
' dictionary ALIAS rom-dictionary	' dictionary ALIAS rom-dictionary


: setup-target ( -- ) \G initialize targets memory space	: setup-target ( -- ) \G initialize target's 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 0<>	\ address-space area nip 0<>
Line 1174 T has? rom H	Line 1386 T has? rom H
ELSE r> drop THEN	ELSE r> drop THEN
REPEAT drop ;	REPEAT drop ;

\ MakeKernal 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 1274 variable constflag constflag off	Line 1489 variable constflag constflag off

bigendian	bigendian
[IF]	[IF]
: S! ( n addr -- ) >r s>d r> tcell bounds swap 1-	: DS! ( d addr -- ) tcell bounds swap 1-
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	: DS@ ( addr -- d ) >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 ;
: Sc! ( n addr -- ) >r s>d r> tchar bounds swap 1-	: Sc! ( n addr -- ) >r s>d r> tchar bounds swap 1-
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;	DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds	: Sc@ ( addr -- n ) >r 0 0 r> tchar 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 ;
[ELSE]	[ELSE]
: S! ( n addr -- ) >r s>d r> tcell bounds	: DS! ( d addr -- ) 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-	: DS@ ( 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 ;
: Sc! ( n addr -- ) >r s>d r> tchar bounds	: Sc! ( n addr -- ) >r s>d r> tchar bounds
DO maxbyte ud/mod rot I c! LOOP 2drop ;	DO maxbyte ud/mod rot I c! LOOP 2drop ;
: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds swap 1-	: 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 ;	DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
[THEN]	[THEN]

	: S! ( n addr -- ) >r s>d r> DS! ;
	: S@ ( addr -- n ) DS@ d>s ;

: taddr>region ( taddr -- region \| 0 )	: taddr>region ( taddr -- region \| 0 )
\G finds for a target-address the correct region	\G finds for a target-address the correct region
\G returns 0 if taddr is not in range of a target memory region	\G returns 0 if taddr is not in range of a target memory region
Line 1426 T has? relocate H	Line 1644 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	>CROSS

: tcmove ( source dest len -- )	Ghost (do) Ghost (?do) 2drop
\G cmove in target memory	Ghost (for) drop
tchar * bounds	Ghost (loop) Ghost (+loop) 2drop
?DO dup T c@ H I T c! H 1+	Ghost (next) drop
tchar +LOOP drop ;	Ghost (does>) Ghost (compile) 2drop
	Ghost (.") Ghost (S") Ghost (ABORT") 2drop drop
	Ghost (C") drop
\ \ Load Assembler	Ghost ' drop

>TARGET
H also Forth definitions

: X 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

[IFDEF] asm-include asm-include [THEN] hex	\ user ghosts

previous	Ghost state drop

\ \ -------------------- Host/Target copy etc. 29aug01jaw	\ \ -------------------- Host/Target copy etc. 29aug01jaw


>CROSS	>CROSS

	: TD! >image DS! ;
	: TD@ >image DS@ ;

: th-count ( taddr -- host-addr len )	: th-count ( taddr -- host-addr len )
\G returns host address of target string	\G returns host address of target string
assert1( tbyte 1 = )	assert1( tbyte 1 = )
Line 1475 previous	Line 1688 previous
>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 ;
: off T 0 swap ! H ;

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

>CROSS

\ Compiler States

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

: compiling? comp-state @ compiling = ;

: Plugin ( -- : pluginname )
Create
['] noop , \ action
['] noop , \ target plugin action
8765 , \ plugin magic
DOES> perform ;

Plugin DummyPlugin

: 'PI ( -- addr : pluginname )
' >body dup 2 cells + @ 8765 <> ABORT" not a plugin" ;

: plugin-of ( xt -- : pluginname )
dup 'PI 2! ;

: action-of ( xt -- : plunginname )
'PI cell+ ! ;

: TPA ( -- : plugin )	: on -1 -1 rot TD! ;
\ target plugin action	: off T 0 swap ! H ;
\ executes current target action of plugin
'PI cell+ POSTPONE literal POSTPONE perform ; immediate

Variable ppi-temp 0 ppi-temp !

: pa:
\g define plugin action
ppi-temp @ ABORT" pa: definition not closed"
'PI ppi-temp ! :noname ;

: ;pa
\g end a definition for plugin action
POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate


Plugin lit, ( n -- )
Plugin alit, ( n -- )

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

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

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

Plugin ncontrols? ( [ xn ... x1 ] n -- ) \ checks wheter n control structures are open
Plugin if, ( -- if-token )
Plugin else, ( if-token -- if-token )
Plugin then, ( if-token -- )
Plugin ahead,
Plugin begin,
Plugin while,
Plugin until,
Plugin again,
Plugin repeat,
Plugin cs-swap ( x1 x2 -- x2 x1 )

Plugin case, ( -- n )
Plugin of, ( n -- x1 n )
Plugin endof, ( x1 n -- x2 n )
Plugin endcase, ( x1 .. xn n -- )

Plugin do, ( -- do-token )	: tcmove ( source dest len -- )
Plugin ?do, ( -- ?do-token )	\G cmove in target memory
Plugin for, ( -- for-token )	tchar * bounds
Plugin loop, ( do-token / ?do-token -- )	?DO dup T c@ H I T c! H 1+
Plugin +loop, ( do-token / ?do-token -- )	tchar +LOOP drop ;
Plugin next, ( for-token )
Plugin leave, ( -- )
Plugin ?leave, ( -- )

[IFUNDEF] ca>native	: td, ( d -- )
Plugin ca>native	\G Store a host value as one cell into the target
[THEN]	there tcell X allot TD! ;

Plugin doprim, \ compiles start of a primitive	\ \ Load Assembler
Plugin docol, \ compiles start of a colon definition
Plugin doer,
Plugin fini, \ compiles end of definition ;s
Plugin doeshandler,
Plugin dodoes,

Plugin colon-start	>TARGET
Plugin colon-end	H also Forth definitions

Plugin ]comp \ starts compilation	\ FIXME: should we include the assembler really in the forth
Plugin comp[ \ ends compilation	\ dictionary?!?!?!? This conflicts with the existing assembler
	\ of the host forth system!!
	[IFDEF] asm-include asm-include [THEN] hex

T 2 cells H Value xt>body	previous

Plugin t>body \ we need the system >body
\ and the target >body

>TARGET
: >body t>body ;
>CROSS	>CROSS

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

: (cr) >tempdp ]comp colon, 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
: (dr) ( ghost res-pnt target-addr addr )	: (dr) ( ghost res-pnt target-addr addr )
>tempdp drop over	>tempdp drop over
Line 1612 Plugin t>body \ we need the	Line 1731 Plugin t>body \ we need the
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 colon, ; ' (cm) plugin-of colonmark,

>TARGET	>TARGET
: compile, colon, ;	: compile, ( xt -- )
	dup xt>ghost >comp @ EXECUTE ;
>CROSS	>CROSS

\ resolve structure	\ resolve structure
Line 1638 Plugin t>body \ we need the	Line 1757 Plugin t>body \ we need the
loadfile ,	loadfile ,
sourceline# ,	sourceline# ,
space>	space>
;	;

: refered ( ghost tag -- )	: refered ( ghost tag -- )
\G creates a resolve structure	\G creates a resolve structure
Line 1696 Defer resolve-warning	Line 1815 Defer resolve-warning
swap exists-warning	swap exists-warning
>link ! ;	>link ! ;

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

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

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

	0 Value resolved

: resolve ( ghost tcfa -- )	: resolve ( ghost tcfa -- )
\G resolve referencies to ghost with tcfa	\G resolve referencies to ghost with tcfa
rdbg @ IF break: THEN
dup taddr>region 0<> IF	dup taddr>region 0<> IF
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 overtake the alias ghost	\ this is for not to take over the alias ghost
	\ (different ghost, but identical xt)
\ but the very first that really defines it	\ but the very first that really defines it
\ FIXME: define when HeaderGhost is ready
dup @ 0= IF ! ELSE 2drop THEN	dup @ 0= IF ! ELSE 2drop THEN
\ !
THEN	THEN

\ is ghost resolved?, second resolve means another	\ is ghost resolved?, second resolve means another
Line 1719 Variable rdbg	Line 1849 Variable rdbg
swap >r r@ >link @ swap \ ( list tcfa R: ghost )	swap >r r@ >link @ swap \ ( list tcfa R: ghost )
\ mark ghost as resolved	\ mark ghost as resolved
dup r@ >link ! <res> r@ >magic !	dup r@ >link ! <res> r@ >magic !
	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
\ loop through forward referencies	\ loop through forward referencies
r> -rot	r> -rot
comp-state @ >r Resolving comp-state !	comp-state @ >r Resolving comp-state !
Line 1730 Variable rdbg	Line 1871 Variable rdbg

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

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

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

: (gexecute) ( ghost -- )	: (gexecute) ( ghost -- )
dup >magic @	dup >comp @ EXECUTE ;
<fwd> = IF is-forward ELSE is-resolved THEN ;

: 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 >magic @ <fwd> = 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

Line 1807 bigendian [IF] 0 [ELSE] tcell 1- [THEN]	Line 1939 bigendian [IF] 0 [ELSE] tcell 1- [THEN]

VARIABLE ^imm	VARIABLE ^imm

	\ !! should be target wordsize specific
	$80 constant alias-mask
	$40 constant immediate-mask
	$20 constant restrict-mask

>TARGET	>TARGET
: immediate 40 flag!	: immediate immediate-mask flag!
^imm @ @ dup <imm> = IF drop EXIT THEN	^imm @ @ dup <imm> = IF drop EXIT THEN
<res> <> ABORT" CROSS: Cannot immediate a unresolved word"	<res> <> ABORT" CROSS: Cannot immediate a unresolved word"
<imm> ^imm @ ! ;	<imm> ^imm @ ! ;
: restrict 20 flag! ;	: restrict restrict-mask flag! ;

: isdoer	: isdoer
\G define a forth word as doer, this makes obviously only sence on	\G define a forth word as doer, this makes obviously only sence on
Line 1847 Variable to-doc to-doc on	Line 1984 Variable to-doc to-doc on
s" " doc-file-id write-line throw	s" " doc-file-id write-line throw
s" make-doc " doc-file-id write-file throw	s" make-doc " doc-file-id write-file throw

tlast @ >image count 1F and doc-file-id write-file throw	Last-Header-Ghost @ >ghostname doc-file-id write-file throw
>in @	>in @
[char] ( parse 2drop	[char] ( parse 2drop
[char] ) parse doc-file-id write-file throw	[char] ) parse doc-file-id write-file throw
Line 1860 Variable to-doc to-doc on	Line 1997 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,

2variable last-loadfilename 0 0 last-loadfilename 2!	2variable last-loadfilename 0 0 last-loadfilename 2!

Line 1878 Create tag-bof 1 c, 0C c,	Line 2017 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
put-load-file-name	put-load-file-name
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 1892 Create tag-bof 1 c, 0C c,	Line 2031 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 1980 Defer setup-execution-semantics	Line 2135 Defer setup-execution-semantics
[ [THEN] ]	[ [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
80 flag!	alias-mask flag!
cross-doc-entry cross-tag-entry	cross-doc-entry cross-tag-entry
setup-execution-semantics	setup-execution-semantics
;	;
Line 2000 Variable aprim-nr -20 aprim-nr !	Line 2155 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 2011 Variable aprim-nr -20 aprim-nr !	Line 2167 Variable aprim-nr -20 aprim-nr !
: Alias ( cfa -- ) \ name	: Alias ( cfa -- ) \ name
>in @ skip? IF 2drop EXIT THEN >in !	>in @ skip? IF 2drop EXIT THEN >in !
(THeader ( S xt ghost )	(THeader ( S xt ghost )
2dup swap gdiscover 0= ABORT" missing" swap copy-execution-semantics	2dup swap xt>ghost swap copy-execution-semantics
over resolve T A, H 80 flag! ;	over resolve T A, H alias-mask flag! ;

Variable last-prim-ghost	Variable last-prim-ghost
0 last-prim-ghost !	0 last-prim-ghost !
Line 2025 Variable last-prim-ghost	Line 2181 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 <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 <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 )
over resolve T A, H 80 flag!	['] prim-resolved over >comp !
	dup >ghost-flags <primitive> set-flag
	over resolve T A, H alias-mask flag!
-1 prim# +! ;	-1 prim# +! ;
>CROSS	>CROSS

Line 2089 Comment ( Comment \	Line 2248 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

>TARGET	>TARGET

: ' ( -- cfa )	: ' ( -- xt )
\ returns the target-cfa of a ghost	\G returns the target-cfa of a ghost
bl word gfind 0= ABORT" CROSS: Ghost don't exists"	bl word gfind 0= ABORT" CROSS: Ghost don't exists"
ghost>cfa ;	g>xt ;

\ FIXME: this works for the current use cases, but is not	\ FIXME: this works for the current use cases, but is not
\ in all cases correct ;-)	\ in all cases correct ;-)
Line 2112 Cond: ['] T ' H alit, ;Cond	Line 2270 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 ghost>cfa ELSE ghost>cfa THEN ; immediate	postpone [G']
	state @ IF postpone g>xt ELSE g>xt THEN ; immediate

\ \ threading modell 13dec92py	\ \ threading modell 13dec92py
\ modularized 14jun97jaw	\ modularized 14jun97jaw

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

: (>body) ( cfa -- pfa )	: (>body) ( cfa -- pfa )
xt>body + ; ' (>body) plugin-of t>body	xt>body + ; ' (>body) plugin-of t>body

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

: (doer,) ( ghost -- )	: (doer,) ( ghost -- )
addr, 1 fillcfa ; ' (doer,) plugin-of doer,	addr, 1 fillcfa ; ' (doer,) plugin-of doer,

	: (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[
addr,	addr,
\ 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
[ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ]	[ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ]
2 fillcfa ; ' (dodoes,) plugin-of dodoes,	2 fillcfa ; ' (dodoes,) plugin-of dodoes,

	: (dlit,) ( n -- ) compile lit td, ; ' (dlit,) plugin-of dlit,

: (lit,) ( n -- ) compile lit T , H ; ' (lit,) plugin-of lit,	: (lit,) ( n -- ) s>d dlit, ; ' (lit,) plugin-of lit,

\ if we dont produce relocatable code alit, defaults to lit, jaw	\ if we dont produce relocatable code alit, defaults to lit, jaw
\ this is just for convenience, so we don't have to define alit,	\ this is just for convenience, so we don't have to define alit,
\ seperately for embedded systems....	\ seperately for embedded systems....
T has? relocate H	T has? relocate H
[IF]	[IF]
: (alit,) ( n -- ) compile lit T a, H ; ' (alit,) plugin-of alit,	: (alit,) ( n -- ) compile lit T a, H ; ' (alit,) plugin-of alit,
[ELSE]	[ELSE]
: (alit,) ( n -- ) lit, ; ' (alit,) plugin-of alit,	: (alit,) ( n -- ) lit, ; ' (alit,) plugin-of alit,
[THEN]	[THEN]

: (fini,) compile ;s ; ' (fini,) plugin-of fini,	: (fini,) compile ;s ; ' (fini,) plugin-of fini,

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

[ 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@ there ca>native resolve
	<do:> r@ >magic !
	r> drop
depth (code) ;	depth (code) ;

: end-code	: end-code
Line 2188 Defer (end-code)	Line 2363 Defer (end-code)
>TARGET	>TARGET
Cond: \G T-\G ;Cond	Cond: \G T-\G ;Cond

Cond: Literal ( n -- ) lit, ;Cond	Cond: Literal ( n -- ) lit, ;Cond
Cond: ALiteral ( n -- ) alit, ;Cond	Cond: ALiteral ( n -- ) alit, ;Cond

: Char ( "<char>" -- ) bl word char+ c@ ;	: Char ( "<char>" -- ) bl word char+ c@ ;
Cond: [Char] ( "<char>" -- ) Char lit, ;Cond	Cond: [Char] ( "<char>" -- ) Char lit, ;Cond

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

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

\ !! Known Bug: Special Literals and plug-ins work only correct	\ !! Known Bug: Special Literals and plug-ins work only correct
\ on 16 and 32 Bit Targets and 32 Bit Hosts!	\ 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>	tcell 1 cells u>
IF compile lit tcell 0 ?DO FF T c, H LOOP	IF compile lit tcell 0 ?DO FF T c, H LOOP
Line 2226 Cond: MAXI	Line 2406 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 2246 Cond: MAXI	Line 2427 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 ( -- )
	\G set states to compililng
Compiling comp-state !	Compiling comp-state !
\ if we have a state in target, change it with the compile state	\ if we have a state in target, change it with the compile state
[G'] state dup undefined? 0= IF >ghost-xt @ execute X on ELSE drop THEN	[G'] state dup undefined? 0=
	IF >ghost-xt @ execute X on ELSE drop THEN ;

	: interpreting-state ( -- )
	\G set states to interpreting
	\ if target has a state variable, change it according to our state
	[G'] state dup undefined? 0=
	IF >ghost-xt @ execute X off ELSE drop THEN
	Interpreting comp-state ! ;

	>TARGET

	: ]
	compiling-state
BEGIN	BEGIN
BEGIN save-input bl word	BEGIN save-input bl word
dup c@ 0= WHILE drop discard refill 0=	dup c@ 0= WHILE drop discard refill 0=
Line 2266 Cond: MAXI	Line 2462 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 !
(THeader ;Resolve ! there ;Resolve cell+ !	(THeader (:) ;
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 2296 Cond: ?EXIT ( -- ) 1 abort" CROSS: using	Line 2493 Cond: ?EXIT ( -- ) 1 abort" CROSS: using
Cond: recurse ( -- ) Last-Header-Ghost @ gexecute ;Cond	Cond: recurse ( -- ) Last-Header-Ghost @ gexecute ;Cond

Cond: ; ( -- )	Cond: ; ( -- )
depth ?dup IF 1- <> ABORT" CROSS: Stack changed"	depth ?dup
ELSE true ABORT" CROSS: Stack empty" THEN	IF 1- <> ABORT" CROSS: Stack changed"
colon-end	ELSE true ABORT" CROSS: Stack empty"
fini,	THEN
comp[	colon-end
;Resolve @	fini,
IF ;Resolve @ ;Resolve cell+ @ resolve THEN	comp[
[G'] state dup undefined? 0= IF >ghost-xt @ execute X off ELSE drop THEN	;Resolve @
Interpreting comp-state !	IF ['] colon-resolved ;Resolve @ >comp !
;Cond	;Resolve @ ;Resolve cell+ @ resolve
Cond: [	THEN
\ if we have a state in target, change it with the compile state	interpreting-state
[G'] state dup undefined? 0= IF >ghost-xt @ execute X off ELSE drop THEN	;Cond
\ [G'] state dup undefined? 0= IF ghost>cfa X >body X off ELSE drop THEN
Interpreting comp-state ! ;Cond	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-compile-does>-hook
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
Last-Header-Ghost @ >do:ghost @ ?dup IF there resolve THEN ;	Last-Header-Ghost @ >do:ghost @ ?dup
	IF there resolve THEN ;

>TARGET	>TARGET
Cond: DOES>	Cond: DOES>
compile (does>) doeshandler,	compile (does>) doeshandler,
resolve-does>-part	resolve-does>-part
\ instant-compile-does>-hook
;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

\ Builder 11may93jaw	\ Builder 11may93jaw

: Builder ( Create-xt do:-xt "name" -- )	0 Value built

	: Builder ( Create-xt do-ghost "name" -- )
\ builds up a builder in current vocabulary	\ builds up a builder in current vocabulary
\ create-xt is executed when word is interpreted	\ create-xt is executed when word is interpreted
\ do:-xt is executet when the created word from builder is executed	\ do:-xt is executed when the created word from builder is executed
\ for do:-xt an additional entry after the normal ghost-enrys is used	\ for do:-xt an additional entry after the normal ghost-entrys is used

Make-Ghost ( Create-xt do:-xt ghost )	ghost to built
dup >created on	built >created @ 0= IF
rot swap ( do:-xt Create-xt ghost )	built >created on
tuck >exec ! >do:ghost ! ;	THEN ;
\ rot swap >exec dup @ ['] NoExec <>
\ IF 2drop ELSE ! THEN , ;

: gdoes, ( ghost -- )	: gdoes, ( ghost -- )
\ makes the codefield for a word that is built	\ makes the codefield for a word that is built
Line 2379 Cond: DOES>	Line 2577 Cond: DOES>
;	;

: takeover-x-semantics ( S constructor-ghost new-ghost -- )	: takeover-x-semantics ( S constructor-ghost new-ghost -- )
\g stores execution 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 @ >exec @ swap >exec2 ! ;	\ using exec or exec2 makes no difference for normal cross-compilation
\ >exec dup @ ['] NoExec =	\ but is usefull for instant where the exec field is already
\ IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ;	\ defined (e.g. Vocabularies)
	2dup >exec @ swap >exec2 !
	>comp @ swap >comp ! ;

	0 Value createhere

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

: TCreate ( <name> -- )	: TCreate ( <name> -- )
create-forward-warn	create-forward-warn
IF ['] reswarn-forward IS resolve-warning THEN	IF ['] reswarn-forward IS resolve-warning THEN
executed-ghost @ (Theader	executed-ghost @ (Theader
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 2399 Cond: DOES>	Line 2607 Cond: DOES>
IF ['] reswarn-forward IS resolve-warning THEN	IF ['] reswarn-forward IS resolve-warning THEN
\ make Alias	\ make Alias
executed-ghost @ (THeader	executed-ghost @ (THeader
dup >created on	dup >created on dup to created
2dup takeover-x-semantics	2dup takeover-x-semantics
there 0 T a, H 80 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 2419 Cond: DOES>	Line 2627 Cond: DOES>
postpone TCreate	postpone TCreate
[ [THEN] ] ;	[ [THEN] ] ;

	: ;Build
	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 ;
\ compiling? ABORT" CROSS: Executing gdoes> while compiling"
\ ?! compiling? IF gexecute true EXIT THEN
>link @ X >body ( false ) ;

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

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

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

: ;DO ( addr [xt] [colon-sys] -- addr )	: DO: ( -- [xt] [colon-sys] )
postpone ; ( S addr xt )	here ghostheader do:ghost!
over >exec ! ; immediate	:noname postpone gdoes> ;

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

	: ;DO ( [xt] [colon-sys] -- )
	postpone ; doexec! ; immediate

	: by ( -- ) \ Name
	Ghost >do:ghost @ do:ghost! ;

	: compile: ( --[xt] [colon-sys] )
	\G defines a compile time action for created words
	\G by this builder
	:noname ;

: by ( -- addr ) \ Name	: ;compile ( [xt] [colon-sys] -- )
Ghost >do:ghost @ ;	postpone ; built >do:ghost @ >comp ! ; immediate

>TARGET
\ Variables and Constants 05dec92py	\ Variables and Constants 05dec92py

Build: ( n -- ) ;
by: :docon ( target-body-addr -- n ) T @ H ;DO
Builder (Constant)	Builder (Constant)
	Build: ( n -- ) ;Build
	by: :docon ( target-body-addr -- n ) T @ H ;DO

Build: ( n -- ) T , H ;
by (Constant)
Builder Constant	Builder Constant
	Build: ( n -- ) T , H ;Build
Build: ( n -- ) T A, H ;
by (Constant)	by (Constant)

Builder AConstant	Builder AConstant
	Build: ( n -- ) T A, H ;Build
	by (Constant)

Build: ( d -- ) T , , H ;
DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
Builder 2Constant	Builder 2Constant
	Build: ( d -- ) T , , H ;Build
	DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO

BuildSmart: ;
by: :dovar ( target-body-addr -- addr ) ;DO
Builder Create	Builder Create
	BuildSmart: ;Build
	by: :dovar ( target-body-addr -- addr ) ;DO

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

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

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

\ User variables 04may94py	\ User variables 04may94py

>CROSS

Variable tup 0 tup !	Variable tup 0 tup !
Variable tudp 0 tudp !	Variable tudp 0 tudp !

Line 2511 Variable tudp 0 tudp !	Line 2726 Variable tudp 0 tudp !
tup @ tudp @ + T A! H	tup @ tudp @ + T A! H
tudp @ dup T cell+ H tudp ! ;	tudp @ dup T cell+ H tudp ! ;

>TARGET

Build: 0 u, X , ;
by: :douser ( ghost -- up-addr ) X @ tup @ + ;DO
Builder User	Builder User
	Build: 0 u, X , ;Build
	by: :douser ( ghost -- up-addr ) X @ tup @ + ;DO

Build: 0 u, X , 0 u, drop ;
by User
Builder 2User	Builder 2User
	Build: 0 u, X , 0 u, drop ;Build
Build: 0 au, X , ;
by User	by User

Builder AUser	Builder AUser
	Build: 0 au, X , ;Build
	by User

	Builder (Value)
	Build: ( n -- ) ;Build
	by: :docon ( target-body-addr -- n ) T @ H ;DO

BuildSmart: T , H ;
by (Constant)
Builder Value	Builder Value
	BuildSmart: T , H ;Build
	by (Value)

BuildSmart: T A, H ;
by (Constant)
Builder AValue	Builder AValue
	BuildSmart: T A, H ;Build
	by (Value)

Defer texecute	Defer texecute

BuildSmart: ( -- ) [T'] noop T A, H ;
by: :dodefer ( ghost -- ) X @ texecute ;DO
Builder Defer	Builder Defer
	BuildSmart: ( -- ) [T'] noop T A, H ;Build
	by: :dodefer ( ghost -- ) X @ texecute ;DO

Build: ( inter comp -- ) swap T immediate A, A, H ;
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
Builder interpret/compile:	Builder interpret/compile:
	Build: ( inter comp -- ) swap T A, A, H ;Build-immediate
	DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO

\ Sturctures 23feb95py	\ Sturctures 23feb95py

>CROSS
: nalign ( addr1 n -- addr2 )	: nalign ( addr1 n -- addr2 )
\ addr2 is the aligned version of addr1 wrt the alignment size n	\ addr2 is the aligned version of addr1 wrt the alignment size n
1- tuck + swap invert and ;	1- tuck + swap invert and ;
>TARGET

Build: ;
by: :dofield T @ H + ;DO
Builder (Field)	Builder (Field)
	Build: ;Build
	by: :dofield T @ H + ;DO

	Builder Field
Build: ( align1 offset1 align size "name" -- align2 offset2 )	Build: ( align1 offset1 align size "name" -- align2 offset2 )
rot dup T , H ( align1 align size offset1 )	rot dup T , H ( align1 align size offset1 )
+ >r nalign r> ;	+ >r nalign r> ;Build
by (Field)	by (Field)
Builder Field

	>TARGET
: struct T 1 chars 0 H ;	: struct T 1 chars 0 H ;
: end-struct T 2Constant H ;	: end-struct T 2Constant H ;

: cell% ( n -- size align )	: cell% ( n -- size align )
T 1 cells H dup ;	T 1 cells H dup ;
	>CROSS

	\ Input-Methods 01py


Build: ( m v -- m' v ) dup T , cell+ H ;
DO: abort" Not in cross mode" ;DO
Builder input-method	Builder input-method
	Build: ( m v -- m' v ) dup T , cell+ H ;Build
Build: ( m v size -- m v' ) over T , H + ;
DO: abort" Not in cross mode" ;DO	DO: abort" Not in cross mode" ;DO

Builder input-var	Builder input-var
	Build: ( m v size -- m v' ) over T , H + ;Build
	DO: abort" Not in cross mode" ;DO

	\ Peephole optimization 05sep01jaw

	\ this section defines different compilation
	\ actions for created words
	\ this will help the peephole optimizer
	\ I (jaw) took this from bernds latest cross-compiler
	\ changes but seperated it from the original
	\ Builder words. The final plan is to put this
	\ into a seperate file, together with the peephole
	\ optimizer for cross


	T has? peephole H [IF]

	>CROSS

	: (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
	\ and constant!!
	\ Builder (Constant)
	\ compile: g>body X @ lit, ;compile

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

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

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

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

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

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

\ structural conditionals 17dec92py	\ structural conditionals 17dec92py

Line 2852 magic 7 + c!	Line 3127 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 2868 magic 7 + c!	Line 3143 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 2879 magic 7 + c!	Line 3154 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 2933 Create name-buf 200 chars allot	Line 3208 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 3086 Variable outfile-fd	Line 3362 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 3099 Variable outfile-fd	Line 3373 Variable outfile-fd
\ \ [IF] [ELSE] [THEN] ... 14sep97jaw	\ \ [IF] [ELSE] [THEN] ... 14sep97jaw

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

Create parsed 20 chars allot \ store word we parsed	Create parsed 20 chars allot \ store word we parsed
Line 3312 previous	Line 3586 previous
: hwords words ;	: hwords words ;
\ : words also ghosts	\ : words also ghosts
\ words previous ;	\ words previous ;
\ : .s .s ;	: .s .s ;
: bye bye ;	: bye bye ;

\ dummy	\ dummy
Line 3356 UNLOCK >CROSS	Line 3630 UNLOCK >CROSS
[IFDEF] extend-cross extend-cross [THEN]	[IFDEF] extend-cross extend-cross [THEN]

LOCK	LOCK

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

Removed from v.1.103
changed lines
	Added in v.1.121