gforth/cross.fs - diff

Return to cross.fs CVS log

Up to [gforth] / gforth

Diff for /gforth/cross.fs between versions 1.106 and 1.118

version 1.106, 2001/09/05 10:18:46	version 1.118, 2002/01/05 20:16:17
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 202 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 690 Variable ppi-temp 0 ppi-temp !	Line 697 Variable ppi-temp 0 ppi-temp !
POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate	POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate


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

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

Plugin colon, ( tcfa -- ) \ compiles call to tcfa at current position	Plugin colon, ( tcfa -- ) \ compiles call to tcfa at current position
	Plugin xt, ( tcfa -- ) \ compiles xt
Plugin prim, ( tcfa -- ) \ compiles primitive invocation	Plugin prim, ( tcfa -- ) \ compiles primitive invocation
Plugin colonmark, ( -- addr ) \ marks a colon call	Plugin colonmark, ( -- addr ) \ marks a colon call
Plugin colon-resolve ( tcfa addr -- )	Plugin colon-resolve ( tcfa addr -- )
Line 890 Variable cross-space-dp-orig	Line 899 Variable cross-space-dp-orig
THEN ;	THEN ;

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

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

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

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

Line 985 Exists-Warnings on	Line 999 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 1002 Variable reuse-ghosts reuse-ghosts off	Line 1015 Variable reuse-ghosts reuse-ghosts off
\ defined words, this is a workaround	\ defined words, this is a workaround
\ for the redefined \ until vocs work	\ for the redefined \ until vocs work
Make-Ghost ;	Make-Ghost ;
[THEN]


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

\ ' >ghostname ALIAS @name	\ ' >ghostname ALIAS @name

	: findghost ( "ghostname" -- ghost )
	bl word gfind 0= ABORT" CROSS: Ghost don't exists" ;

: [G'] ( -- ghost : name )	: [G'] ( -- ghost : name )
\G ticks a ghost and returns its address	\G ticks a ghost and returns its address
\ bl word gfind 0= ABORT" CROSS: Ghost don't exists"	findghost
ghost state @ IF postpone literal THEN ; immediate	state @ IF postpone literal THEN ; immediate

: g>xt ( ghost -- xt )	: g>xt ( ghost -- xt )
\G Returns the xt (cfa) of a ghost. Issues a warning if undefined.	\G Returns the xt (cfa) of a ghost. Issues a warning if undefined.
Line 1043 End-Struct addr-struct	Line 1057 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 :docol Ghost :doesjump Ghost :dodoes 2drop drop
Ghost :dovar 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

\ \ 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 1144 true DefaultValue standardthreading	Line 1163 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 1226 Variable mirrored-link \ linked	Line 1248 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 1239 Variable mirrored-link \ linked	Line 1265 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 1358 T has? rom H	Line 1383 T has? rom H

\ MakeKernel 22feb99jaw	\ MakeKernel 22feb99jaw

: makekernel ( targetsize -- targetsize )	: makekernel ( targetsize -- )
dup dictionary >rlen ! setup-target ;	\G convenience word to setup the memory of the target
	\G used by main.fs of the c-engine based systems
	100 swap dictionary (region)
	setup-target ;

>MINIMAL	>MINIMAL
: makekernel makekernel ;	: makekernel makekernel ;
Line 1611 T has? relocate H	Line 1639 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 -- )	: call-forward ( ghost -- )
\G cmove in target memory	there 0 colon, 0 do-refered ;
tchar * bounds	' call-forward IS is-forward
?DO dup T c@ H I T c! H 1+
tchar +LOOP drop ;


\ \ Load Assembler	Ghost (do) Ghost (?do) 2drop
	Ghost (for) drop
	Ghost (loop) Ghost (+loop) 2drop
	Ghost (next) drop
	Ghost (does>) Ghost (compile) 2drop
	Ghost (.") Ghost (S") Ghost (ABORT") 2drop drop
	Ghost (C") drop
	Ghost ' drop

>TARGET	\ ' prim-forward IS is-forward
H also Forth definitions

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

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 1657 previous	Line 1689 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 ;	: on -1 -1 rot TD! ;
: off T 0 swap ! H ;	: off T 0 swap ! H ;

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

	: td, ( d -- )
	\G Store a host value as one cell into the target
	there tcell X allot TD! ;

	\ \ Load Assembler

	>TARGET
	H also Forth definitions

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

	previous


>CROSS	>CROSS

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

: (cr) >tempdp ]comp prim, comp[ tempdp> ; ' (cr) plugin-of colon-resolve	: (cr) >tempdp colon, tempdp> ; ' (cr) plugin-of colon-resolve
: (ar) T ! H ; ' (ar) plugin-of addr-resolve	: (ar) T ! H ; ' (ar) plugin-of addr-resolve
: (dr) ( ghost res-pnt target-addr addr )	: (dr) ( ghost res-pnt target-addr addr )
>tempdp drop over	>tempdp drop over
Line 1678 previous	Line 1734 previous

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

>TARGET	>TARGET
: compile, ( xt -- )	: compile, ( xt -- )
dup xt>ghost >ghost-flags <primitive> get-flag	dup xt>ghost >comp @ EXECUTE ;
IF prim, ELSE colon, THEN ;
>CROSS	>CROSS

\ resolve structure	\ resolve structure
Line 1705 previous	Line 1760 previous
loadfile ,	loadfile ,
sourceline# ,	sourceline# ,
space>	space>
;	;

	' (refered) IS do-refered

: refered ( ghost tag -- )	: refered ( ghost tag -- )
\G creates a resolve structure	\G creates a resolve structure
Line 1769 Defer resolve-warning	Line 1826 Defer resolve-warning
: prim-resolved ( ghost -- )	: prim-resolved ( ghost -- )
>link @ prim, ;	>link @ prim, ;

\ FIXME: not activated	0 Value resolved
: does-resolved ( ghost -- )
dup g>body alit, >do:ghost @ g>body colon, ;

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

: resolve ( ghost tcfa -- )	: resolve ( ghost tcfa -- )
\G resolve referencies to ghost with tcfa	\G resolve referencies to ghost with tcfa
Line 1796 Defer resolve-warning	Line 1847 Defer resolve-warning
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@ >comp @ ['] is-forward = IF	r@ to resolved
	r@ >comp @ ['] prim-forward = IF
	['] prim-resolved r@ >comp ! THEN
	r@ >comp @ what's is-forward = IF
['] prim-resolved r@ >comp ! THEN	['] prim-resolved r@ >comp ! THEN
\ loop through forward referencies	\ loop through forward referencies
r> -rot	r> -rot
Line 1809 Defer resolve-warning	Line 1863 Defer resolve-warning

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

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

: (gexecute) ( ghost -- )	: (gexecute) ( ghost -- )
dup >comp @ EXECUTE ;	dup >comp @ EXECUTE ;

Line 1823 Defer resolve-warning	Line 1873 Defer resolve-warning
: addr, ( ghost -- )	: addr, ( ghost -- )
dup forward? IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ;	dup forward? IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ;

\ !! : ghost, ghost gexecute ;

\ .unresolved 11may93jaw	\ .unresolved 11may93jaw

variable ResolveFlag	variable ResolveFlag
Line 1941 Variable to-doc to-doc on	Line 1989 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 1959 Create tag-bof 1 c, 0C c,	Line 2009 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 1973 Create tag-bof 1 c, 0C c,	Line 2023 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 2081 Variable aprim-nr -20 aprim-nr !	Line 2147 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 2106 Variable last-prim-ghost	Line 2173 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, ;
Line 2127 Defer setup-prim-semantics	Line 2194 Defer setup-prim-semantics
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-forward IS is-forward
prim# @ (THeader ( S xt ghost )	prim# @ (THeader ( S xt ghost )
dup >ghost-flags <primitive> set-flag	dup >ghost-flags <primitive> set-flag
over resolve T A, H alias-mask flag!	over resolve T A, H alias-mask flag!
	\ ['] call-forward IS is-forward
-1 prim# +! ;	-1 prim# +! ;
>CROSS	>CROSS

Line 2171 Comment ( Comment \	Line 2240 Comment ( Comment \
\ compile 10may93jaw	\ compile 10may93jaw

: compile ( "name" -- ) \ name	: compile ( "name" -- ) \ name
\ bl word gfind 0= ABORT" CROSS: Can't compile "	findghost
ghost
dup >exec-compile @ ?dup	dup >exec-compile @ ?dup
IF nip compile,	IF nip compile,
ELSE postpone literal postpone gexecute THEN ; immediate restrict	ELSE postpone literal postpone gexecute THEN ; immediate restrict
Line 2194 Cond: ['] T ' H alit, ;Cond	Line 2262 Cond: ['] T ' H alit, ;Cond

: [T']	: [T']
\ returns the target-cfa of a ghost, or compiles it as literal	\ returns the target-cfa of a ghost, or compiles it as literal
postpone [G'] state @ IF postpone g>xt ELSE g>xt THEN ; immediate	postpone [G']
	state @ IF postpone g>xt ELSE g>xt THEN ; immediate

\ \ threading modell 13dec92py	\ \ threading modell 13dec92py
\ modularized 14jun97jaw	\ modularized 14jun97jaw
Line 2228 T 2 cells H Value xt>body	Line 2297 T 2 cells H Value xt>body
[ 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,

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

	: (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,
Line 2289 Cond: chars ;Cond	Line 2360 Cond: chars ;Cond
\ !! 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 2314 Cond: MAXI	Line 2388 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 2334 Cond: MAXI	Line 2409 Cond: MAXI
IF 0> IF swap lit, THEN lit, discard	IF 0> IF swap lit, THEN lit, discard
ELSE 2drop restore-input throw Ghost gexecute THEN ;	ELSE 2drop restore-input throw Ghost gexecute THEN ;

>TARGET
\ : ; DOES> 13dec92py	\ : ; DOES> 13dec92py
\ ] 9may93py/jaw	\ ] 9may93py/jaw

	>CROSS

: compiling-state ( -- )	: compiling-state ( -- )
\G set states to compililng	\G set states to compililng
Compiling comp-state !	Compiling comp-state !
Line 2352 Cond: MAXI	Line 2428 Cond: MAXI
IF >ghost-xt @ execute X off ELSE drop THEN	IF >ghost-xt @ execute X off ELSE drop THEN
Interpreting comp-state ! ;	Interpreting comp-state ! ;

	>TARGET

: ]	: ]
compiling-state	compiling-state
BEGIN	BEGIN
Line 2366 Cond: MAXI	Line 2444 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 2404 Cond: ; ( -- )	Line 2483 Cond: ; ( -- )
fini,	fini,
comp[	comp[
;Resolve @	;Resolve @
IF ;Resolve @ ;Resolve cell+ @ resolve	IF ['] colon-resolved ;Resolve @ >comp !
['] colon-resolved ;Resolve @ >comp !	;Resolve @ ;Resolve cell+ @ resolve
THEN	THEN
interpreting-state	interpreting-state
;Cond	;Cond
Line 2414 Cond: [ ( -- ) interpreting-state ;Cond	Line 2493 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!	r@ created >do:ghost ! r@ swap resolve
GhostDummy >link ! GhostDummy	r> tlastcfa @ >tempdp dodoes, tempdp> ;
tlastcfa @ >tempdp dodoes, tempdp> ;


Defer instant-interpret-does>-hook	Defer instant-interpret-does>-hook

	: does-resolved ( ghost -- )
	compile does-exec g>xt T a, H ;
	\ dup g>body alit, >do:ghost @ g>xt 0 t>body - colon, ;

: resolve-does>-part ( -- )	: resolve-does>-part ( -- )
\ resolve words made by builders	\ resolve words made by builders
Last-Header-Ghost @ >do:ghost @ ?dup	Last-Header-Ghost @ >do:ghost @ ?dup
IF there resolve	IF there resolve THEN ;
\ TODO: set special DOES> resolver action here
THEN ;

>TARGET	>TARGET
Cond: DOES>	Cond: DOES>
Line 2441 Cond: DOES>	Line 2518 Cond: DOES>
resolve-does>-part	resolve-does>-part
;Cond	;Cond

: DOES> switchrom doeshandler, T here H !does	: DOES>
instant-interpret-does>-hook	['] does-resolved created >comp !
depth T ] H ;	switchrom doeshandler, T here H !does
	instant-interpret-does>-hook
	depth T ] H ;

>CROSS	>CROSS
\ Creation 01nov92py	\ Creation 01nov92py

\ Builder 11may93jaw	\ Builder 11may93jaw

	0 Value built

: Builder ( Create-xt do-ghost "name" -- )	: 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 executed 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-entrys is used	\ for do:-xt an additional entry after the normal ghost-entrys is used

Make-Ghost ( Create-xt do-ghost ghost )	ghost to built
dup >created on	built >created @ 0= IF
rot swap ( do-ghost Create-xt ghost )	built >created on
tuck >exec !	THEN ;
tuck >do:ghost !
['] prim-resolved over >comp !
drop ;

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

: takeover-x-semantics ( S constructor-ghost new-ghost -- )	: takeover-x-semantics ( S constructor-ghost new-ghost -- )
\g stores execution semantic and compilation semantic in the built word	\g stores execution semantic and compilation semantic in the built word
\g if the word already has a semantic (concerns S", IS, .", DOES>)	swap >do:ghost @ 2dup swap >do:ghost !
\g then keep it	\ we use the >exec2 field for the semantic of a created word,
swap >do:ghost @	\ using exec or exec2 makes no difference for normal cross-compilation
\ we use the >exec2 field for the semantic of a crated word,	\ but is usefull for instant where the exec field is already
\ so predefined semantics e.g. for ....	\ defined (e.g. Vocabularies)
\ FIXME: find an example in the normal kernel!!!
2dup >exec @ swap >exec2 !	2dup >exec @ swap >exec2 !
>comp @ swap >comp ! ;	>comp @ swap >comp ! ;
\ old version of this:
\ >exec dup @ ['] NoExec =	0 Value createhere
\ IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ;
	: create-resolve ( -- )
	created createhere resolve 0 ;Resolve ! ;
	: create-resolve-immediate ( -- )
	create-resolve T immediate H ;

: TCreate ( <name> -- )	: TCreate ( <name> -- )
create-forward-warn	create-forward-warn
IF ['] reswarn-forward IS resolve-warning THEN	IF ['] reswarn-forward IS resolve-warning THEN
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 2507 Cond: DOES>	Line 2589 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 alias-mask flag!	there 0 T a, H alias-mask flag!
\ store poiter to code-field	\ store poiter to code-field
switchram T cfalign H	switchram T cfalign H
there swap T ! H	there swap T ! H
there tlastcfa !	there tlastcfa !
hereresolve gdoes, ;	there to createhere drop gdoes, ;

: Build: ( -- [xt] [colon-sys] )	: Build: ( -- [xt] [colon-sys] )
:noname postpone TCreate ;	:noname postpone TCreate ;
Line 2527 Cond: DOES>	Line 2609 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 ;
\ FIXME: cleanup
\ compiling? ABORT" CROSS: Executing gdoes> while compiling"
\ ?! compiling? IF gexecute true EXIT THEN
g>body ( false ) ;

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

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

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

: ;DO ( ghost [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 2620 Variable tudp 0 tudp !	Line 2708 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	\ 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 lates 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,
	: (call-res) >tempdp resolved gexecute tempdp> drop ;
	' (call-res) plugin-of colon-resolve
	: (prim) dup 0< IF ( $4000 - ) ELSE
	." wrong usage of (prim) "
	dup gdiscover IF .ghost ELSE . THEN cr -2 throw THEN
	T a, H ; ' (prim) 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 2961 magic 7 + c!	Line 3108 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 2977 magic 7 + c!	Line 3124 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 2988 magic 7 + c!	Line 3135 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 3042 Create name-buf 200 chars allot	Line 3189 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 3195 Variable outfile-fd	Line 3343 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 3208 Variable outfile-fd	Line 3354 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 3465 UNLOCK >CROSS	Line 3611 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.106
changed lines
	Added in v.1.118