gforth/cross.fs - diff

Return to cross.fs CVS log

Up to [gforth] / gforth

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

version 1.109, 2001/09/05 13:11:36	version 1.117, 2002/01/04 20:31:53
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 705 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 986 Exists-Warnings on	Line 994 Exists-Warnings on

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

1 [IF] \ FIXME: define when vocs are ready
: HeaderGhost ( "name" -- ghost )	: HeaderGhost ( "name" -- ghost )
>in @	>in @
bl word count	bl word count
Line 1003 Variable reuse-ghosts reuse-ghosts off	Line 1010 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 1046 End-Struct addr-struct	Line 1054 End-Struct addr-struct

\ 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 (do) Ghost (?do) 2drop
Line 1060 Ghost '	Line 1070 Ghost '
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 state drop
	Ghost call drop
	Ghost @ drop
	Ghost useraddr drop
	Ghost execute drop
	Ghost + drop
	Ghost (C") drop
	Ghost decimal drop
	Ghost hex drop

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

Line 1145 true DefaultValue standardthreading	Line 1161 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 1227 Variable mirrored-link \ linked	Line 1246 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 1240 Variable mirrored-link \ linked	Line 1263 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 1359 T has? rom H	Line 1381 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 1640 T has? relocate H	Line 1665 T has? relocate H
>TARGET	>TARGET

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

: tcmove ( source dest len -- )	: tcmove ( source dest len -- )
Line 1670 previous	Line 1695 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 ]comp xt, comp[ 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 1684 previous	Line 1710 previous

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

>TARGET	>TARGET
: compile, ( xt -- )	: compile, ( xt -- )
Line 1774 Defer resolve-warning	Line 1800 Defer resolve-warning
: prim-resolved ( ghost -- )	: prim-resolved ( ghost -- )
>link @ prim, ;	>link @ prim, ;

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

: (is-forward) ( ghost -- )	: (is-forward) ( ghost -- )
colonmark, 0 (refered) ; \ compile space for call	colonmark, 0 (refered) ; \ compile space for call
Line 1814 Defer resolve-warning	Line 1840 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 ;

: gexecute ( ghost -- )	: gexecute ( ghost -- )
\ dup >magic @ <imm> = IF -1 ABORT" CROSS: gexecute on immediate word" THEN	dup >magic @ <imm> = IF -1 ABORT" CROSS: gexecute on immediate word" THEN
(gexecute) ;	(gexecute) ;

: addr, ( ghost -- )	: addr, ( ghost -- )
dup forward? IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ;	dup forward? IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ;

\ !! : ghost, ghost gexecute ;

\ .unresolved 11may93jaw	\ .unresolved 11may93jaw

variable ResolveFlag	variable ResolveFlag
Line 1946 Variable to-doc to-doc on	Line 1966 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 1964 Create tag-bof 1 c, 0C c,	Line 1986 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 1978 Create tag-bof 1 c, 0C c,	Line 2000 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 2086 Variable aprim-nr -20 aprim-nr !	Line 2124 Variable aprim-nr -20 aprim-nr !
: copy-execution-semantics ( ghost-from ghost-dest -- )	: copy-execution-semantics ( ghost-from ghost-dest -- )
>r	>r
dup >exec @ r@ >exec !	dup >exec @ r@ >exec !
	dup >comp @ r@ >comp !
dup >exec2 @ r@ >exec2 !	dup >exec2 @ r@ >exec2 !
dup >exec-compile @ r@ >exec-compile !	dup >exec-compile @ r@ >exec-compile !
dup >ghost-xt @ r@ >ghost-xt !	dup >ghost-xt @ r@ >ghost-xt !
Line 2111 Variable last-prim-ghost	Line 2150 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 2132 Defer setup-prim-semantics	Line 2171 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
Line 2176 Comment ( Comment \	Line 2215 Comment ( Comment \
\ compile 10may93jaw	\ compile 10may93jaw

: compile ( "name" -- ) \ name	: compile ( "name" -- ) \ name
\ bl word gfind 0= ABORT" CROSS: Can't compile "	findghost
ghost
dup >exec-compile @ ?dup	dup >exec-compile @ ?dup
IF nip compile,	IF nip compile,
ELSE postpone literal postpone gexecute THEN ; immediate restrict	ELSE postpone literal postpone gexecute THEN ; immediate restrict
Line 2199 Cond: ['] T ' H alit, ;Cond	Line 2237 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 2288 Cond: ALiteral ( n -- ) alit, ;Cond	Line 2327 Cond: ALiteral ( n -- ) alit, ;Cond
Cond: [Char] ( "<char>" -- ) Char lit, ;Cond	Cond: [Char] ( "<char>" -- ) Char lit, ;Cond

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

\ some special literals 27jan97jaw	\ some special literals 27jan97jaw
Line 2324 Cond: MAXI	Line 2363 Cond: MAXI
;Cond	;Cond

>CROSS	>CROSS

\ Target compiling loop 12dec92py	\ Target compiling loop 12dec92py
\ ">tib trick thrown out 10may93jaw	\ ">tib trick thrown out 10may93jaw
\ number? defined at the top 11may93jaw	\ number? defined at the top 11may93jaw
Line 2344 Cond: MAXI	Line 2384 Cond: MAXI
IF 0> IF swap lit, THEN lit, discard	IF 0> IF swap lit, THEN lit, discard
ELSE 2drop restore-input throw Ghost gexecute THEN ;	ELSE 2drop restore-input throw Ghost gexecute THEN ;

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

	>CROSS

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

	>TARGET

: ]	: ]
compiling-state	compiling-state
BEGIN	BEGIN
Line 2376 Cond: MAXI	Line 2419 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 2424 Cond: [ ( -- ) interpreting-state ;Cond	Line 2468 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

: 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 2452 Cond: DOES>	Line 2490 Cond: DOES>
;Cond	;Cond

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

Line 2471 Cond: DOES>	Line 2510 Cond: DOES>
ghost to built	ghost to built
built >created @ 0= IF	built >created @ 0= IF
built >created on	built >created on
['] prim-resolved built >comp !
THEN ;	THEN ;

: gdoes, ( ghost -- )	: gdoes, ( ghost -- )
Line 2491 Cond: DOES>	Line 2529 Cond: DOES>
;	;

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

: 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 hereresolve gdoes, ;

: RTCreate ( <name> -- )	: RTCreate ( <name> -- )
Line 2543 Cond: DOES>	Line 2575 Cond: DOES>
postpone ; built >exec ! ; immediate	postpone ; built >exec ! ; immediate

: gdoes> ( ghost -- addr flag )	: gdoes> ( ghost -- addr flag )
executed-ghost @	executed-ghost @ g>body ;
\ FIXME: cleanup
\ compiling? ABORT" CROSS: Executing gdoes> while compiling"
\ ?! compiling? IF gexecute true EXIT THEN
g>body ( false ) ;

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

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

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

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

: ;DO ( [xt] [colon-sys] -- )	: ;DO ( [xt] [colon-sys] -- )
postpone ; doexec! ; immediate	postpone ; doexec! ; immediate
Line 2724 T has? peephole H [IF]	Line 2751 T has? peephole H [IF]

>CROSS	>CROSS
: (callc) compile call T >body a, H ; ' (callc) plugin-of colon,	: (callc) compile call T >body a, H ; ' (callc) plugin-of colon,
	: (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	\ if we want this, we have to spilt aconstant
\ and constant!!	\ and constant!!
Line 2738 compile: g>body alit, compile @ ;compile	Line 2769 compile: g>body alit, compile @ ;compile

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

Builder User	Builder User
compile: g>body compile useraddr T @ , H ;compile	compile: g>body compile useraddr T @ , H ;compile
Line 2749 compile: g>body alit, compile @ compile	Line 2780 compile: g>body alit, compile @ compile
Builder (Field)	Builder (Field)
compile: g>body T @ H lit, compile + ;compile	compile: g>body T @ H lit, compile + ;compile

	Builder interpret/compile:
	compile: does-resolved ;compile

	Builder input-method
	compile: does-resolved ;compile

	Builder input-var
	compile: does-resolved ;compile

[THEN]	[THEN]

\ structural conditionals 17dec92py	\ structural conditionals 17dec92py
Line 3023 magic 7 + c!	Line 3063 magic 7 + c!
: save-cross ( "image-name" "binary-name" -- )	: save-cross ( "image-name" "binary-name" -- )
bl parse ." Saving to " 2dup type cr	bl parse ." Saving to " 2dup type cr
w/o bin create-file throw >r	w/o bin create-file throw >r
TNIL IF	s" header" X $has? IF
s" #! " r@ write-file throw	s" #! " r@ write-file throw
bl parse r@ write-file throw	bl parse r@ write-file throw
s" --image-file" r@ write-file throw	s" --image-file" r@ write-file throw
Line 3039 magic 7 + c!	Line 3079 magic 7 + c!
THEN	THEN
image @ there	image @ there
r@ write-file throw \ write image	r@ write-file throw \ write image
TNIL IF	s" relocate" X $has? IF
bit$ @ there 1- tcell>bit rshift 1+	bit$ @ there 1- tcell>bit rshift 1+
r@ write-file throw \ write tags	r@ write-file throw \ write tags
THEN	THEN
Line 3050 magic 7 + c!	Line 3090 magic 7 + c!
swap >image swap r@ write-file throw	swap >image swap r@ write-file throw
r> close-file throw ;	r> close-file throw ;

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

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

	\ FIXME why disabled?!
: label-from-ghostnameXX ( ghost -- addr len )	: label-from-ghostnameXX ( ghost -- addr len )
\ same as (label-from-ghostname) but caches generated names	\ same as (label-from-ghostname) but caches generated names
dup >asm-name @ ?dup IF nip count EXIT THEN	dup >asm-name @ ?dup IF nip count EXIT THEN
Line 3257 Variable outfile-fd	Line 3298 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 3527 UNLOCK >CROSS	Line 3566 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.109
changed lines
	Added in v.1.117