gforth/cross.fs - diff

Return to cross.fs CVS log

Up to [gforth] / gforth

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

version 1.53, 1997/09/13 12:04:55	version 1.63, 1998/12/22 21:17:14
Line 1	Line 1
\ CROSS.FS The Cross-Compiler 06oct92py	\ CROSS.FS The Cross-Compiler 06oct92py
\ Idea and implementation: Bernd Paysan (py)	\ Idea and implementation: Bernd Paysan (py)

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

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

Line 41	Line 41
\ mach file is only loaded into target	\ mach file is only loaded into target
\ cell corrected	\ cell corrected
\ romable extansions 27apr97-5jun97jaw	\ romable extansions 27apr97-5jun97jaw
	\ environmental query support 01sep97jaw
	\ added own [IF] ... [ELSE] ... [THEN] 14sep97jaw
	\ extra resolver for doers 20sep97jaw
	\ added killref for DOES> 20sep97jaw


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

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

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

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

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

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

hex	hex

Line 149 stack-warn [IF]	Line 154 stack-warn [IF]
[THEN]	[THEN]



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

\ second name source to search trough list	\ second name source to search trough list
Line 234 VARIABLE Already	Line 240 VARIABLE Already
BEGIN @ dup	BEGIN @ dup
WHILE 2dup cell+ @ =	WHILE 2dup cell+ @ =
UNTIL nip 2 cells + count	UNTIL nip 2 cells + count
ELSE 2drop true abort" CROSS: Ghostnames inconsistent"	ELSE 2drop
	\ true abort" CROSS: Ghostnames inconsistent"
	s" ?!?!?!"
THEN ;	THEN ;

' >ghostname ALIAS @name	' >ghostname ALIAS @name
Line 256 ghost (does>) ghost noop	Line 264 ghost (does>) ghost noop
ghost (.") ghost (S") ghost (ABORT") 2drop drop	ghost (.") ghost (S") ghost (ABORT") 2drop drop
ghost ' drop	ghost ' drop
ghost :docol ghost :doesjump ghost :dodoes 2drop drop	ghost :docol ghost :doesjump ghost :dodoes 2drop drop
	ghost :dovar drop
ghost over ghost = ghost drop 2drop drop	ghost over ghost = ghost drop 2drop drop
ghost - drop	ghost - drop
	ghost 2drop drop
	ghost 2dup drop

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

Line 286 VARIABLE env-current \ save information	Line 297 VARIABLE env-current \ save information

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

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


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

>ENVIRON	>ENVIRON

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

	true DefaultValue interpreter
	true DefaultValue ITC
	false DefaultValue rom

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

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

	1 8 lshift Constant maxbyte
T	T
NIL Constant TNIL	NIL Constant TNIL
cell Constant tcell	cell Constant tcell
cell<< Constant tcell<<	cell<< Constant tcell<<
cell>bit Constant tcell>bit	cell>bit Constant tcell>bit
bits/byte Constant tbits/byte	bits/byte Constant tbits/byte
	bits/byte 8 / Constant tchar
float Constant tfloat	float Constant tfloat
1 bits/byte lshift Constant maxbyte	1 bits/byte lshift Constant tmaxbyte
H	H

\ Variables 06oct92py	\ Variables 06oct92py
Line 358 Variable user-vars 0 user-vars !	Line 387 Variable user-vars 0 user-vars !

>CROSS	>CROSS

\ memregion.fs	\ \ memregion.fs


Variable last-defined-region \ pointer to last defined region	Variable last-defined-region \ pointer to last defined region
Line 473 T has? rom H	Line 502 T has? rom H
ABORT" CROSS: define at least address-space or dictionary!!"	ABORT" CROSS: define at least address-space or dictionary!!"
+ makekernel drop ;	+ makekernel drop ;

\ switched tdp for rom support 03jun97jaw	\ \ switched tdp for rom support 03jun97jaw

\ second value is here to store some maximal value for statistics	\ second value is here to store some maximal value for statistics
\ tempdp is also embedded here but has nothing to do with rom support	\ tempdp is also embedded here but has nothing to do with rom support
Line 564 bigendian	Line 593 bigendian
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;	DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
: S@ ( addr -- n ) >r 0 0 r> tcell bounds	: S@ ( addr -- n ) >r 0 0 r> tcell bounds
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;	DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;
	: Sc! ( n addr -- ) >r s>d r> tchar bounds swap 1-
	DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
	: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds
	DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;
[ELSE]	[ELSE]
: S! ( n addr -- ) >r s>d r> tcell bounds	: S! ( n addr -- ) >r s>d r> tcell bounds
DO maxbyte ud/mod rot I c! LOOP 2drop ;	DO maxbyte ud/mod rot I c! LOOP 2drop ;
: S@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1-	: S@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1-
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;	DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
	: Sc! ( n addr -- ) >r s>d r> tchar bounds
	DO maxbyte ud/mod rot I c! LOOP 2drop ;
	: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds swap 1-
	DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
[THEN]	[THEN]

>CROSS	>CROSS
Line 604 CREATE Bittable 80 c, 40 c, 20 c, 10 c,	Line 641 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
>TARGET	>TARGET
: @ ( taddr -- w ) >image S@ ;	: @ ( taddr -- w ) >image S@ ;
: ! ( w taddr -- ) >image S! ;	: ! ( w taddr -- ) >image S! ;
: c@ ( taddr -- char ) >image c@ ;	: c@ ( taddr -- char ) >image Sc@ ;
: c! ( char taddr -- ) >image c! ;	: c! ( char taddr -- ) >image Sc! ;
: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;	: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
: 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;	: 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;

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

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

>CROSS	>CROSS

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

>TARGET	>TARGET
H also Forth definitions \ ." asm: " order	H also Forth definitions \ ." asm: " order
Line 648 previous	Line 686 previous

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

	\ Compiler States

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

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

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

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

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

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

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

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

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

\ file loading	\ file loading

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

Variable filelist 0 filelist !	Variable filelist 0 filelist !
0 Value loadfile	0 Value filemem
	: loadfile filemem >fl-name ;

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

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

: included? ( c-addr u -- f )	: included? ( c-addr u -- f )
filelist	filelist
Line 712 Variable filelist 0 filelist !	Line 788 Variable filelist 0 filelist !
2drop drop false ;	2drop drop false ;

: included	: included
cr ." Including: " 2dup type ." ..."	\ cr ." Including: " 2dup type ." ..."
2dup add-included-file included ;	FileMem >r
	2dup add-included-file included
	r> to FileMem ;

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

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

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

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

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

Defer resolve-warning	Defer resolve-warning
Line 750 Defer resolve-warning	Line 848 Defer resolve-warning

\ resolve 14oct92py	\ resolve 14oct92py

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

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

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

	['] noop IS resolve-warning
;	;

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

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

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

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

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

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

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

: T-\G ( -- )	: T-\G ( -- )
Line 975 Defer skip? ' false IS skip?	Line 1090 Defer skip? ' false IS skip?

\ Target header creation	\ Target header creation

	Variable CreateFlag
	CreateFlag off

VARIABLE CreateFlag CreateFlag off	Variable NoHeaderFlag
	NoHeaderFlag off

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

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

VARIABLE ;Resolve 1 cells allot	VARIABLE ;Resolve 1 cells allot
\ this is the resolver information from ":"	\ this is the resolver information from ":"
Line 1095 Cond: ['] T ' H alit, ;Cond	Line 1226 Cond: ['] T ' H alit, ;Cond
\ modularized 14jun97jaw	\ modularized 14jun97jaw

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

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

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

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

>CROSS	>CROSS

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

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

>CROSS	>CROSS

	Create GhostDummy ghostheader
	<res> GhostDummy >magic !

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

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

>in @ alias2 swap dup >in ! >r >r	>in @ alias2 swap dup >in ! >r >r
Make-Ghost rot swap >exec ! ,	Make-Ghost
	rot swap >exec dup @ ['] NoExec <>
	IF 2drop ELSE ! THEN
	,
r> r> >in !	r> r> >in !
also ghosts ' previous swap ! ;	also ghosts ' previous swap ! ;
\ DOES> dup >exec @ execute ;	\ DOES> dup >exec @ execute ;
Line 1294 Cond: DOES> restrict?	Line 1436 Cond: DOES> restrict?
>end @ dup forward? 0=	>end @ dup forward? 0=
IF	IF
dup >magic @ <do:> =	dup >magic @ <do:> =
IF doer, EXIT THEN	IF doer,
	ELSE dodoes,
	THEN
	EXIT
THEN	THEN
\ compile :dodoes gexecute	\ compile :dodoes gexecute
\ T here H tcell - reloff	\ T here H tcell - reloff
dodoes,	2 refered
;	0 fillcfa
	;

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

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

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

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

0 [IF]

\ structural conditionals 17dec92py	\ structural conditionals 17dec92py

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

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

\ Structural Conditionals 12dec92py

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

>CROSS
Variable tleavings
>TARGET

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

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

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

\ Structural Conditionals 12dec92py

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

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

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

\ Structural Conditionals 12dec92py

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

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

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

[ELSE]

\ structural conditionals 17dec92py

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

: branchoffset ( src dest -- ) - ;

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

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

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

>TARGET	>TARGET

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

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

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

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

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

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

>TARGET	>TARGET

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

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

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

[THEN]	[THEN]

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

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

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

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

	>TARGET

\ Structural Conditionals 12dec92py	\ Structural Conditionals 12dec92py

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

\ Structural Conditionals 12dec92py	\ Structural Conditionals 12dec92py

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

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

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

\ String words 23feb93py	\ String words 23feb93py

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

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

	\ \ minimal definitions

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

: KB 400 * ;	: KB 400 * ;

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

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

	Create parsed 20 chars allot \ store word we parsed

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

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

	: [THEN] ( -- ) ; immediate

	: [ENDIF] ( -- ) ; immediate

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

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

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

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

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

	Cond: [IFDEF] postpone [IFDEF] ;Cond

	Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond

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

: C: >in @ defined? 0=	: C: >in @ defined? 0=
Line 1760 Cond: \D \D ;Cond	Line 1949 Cond: \D \D ;Cond
\G defines ghost for words that we want to be compiled	\G defines ghost for words that we want to be compiled
BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;	BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;

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

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

previous	previous

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

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

char 1 bigendian + tcell + magic 7 + c!	bigendian 1+ \ strangely, in magic big=0, little=1
	tcell 1 = 0 and or
	tcell 2 = 2 and or
	tcell 4 = 4 and or
	tcell 8 = 6 and or
	magic 7 + c!

: save-cross ( "image-name" "binary-name" -- )	: save-cross ( "image-name" "binary-name" -- )
bl parse ." Saving to " 2dup type cr	bl parse ." Saving to " 2dup type cr
Line 1818 also minimal	Line 2002 also minimal

bigendian Constant bigendian	bigendian Constant bigendian
: here there ;	: here there ;

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

: save-cross save-cross ;	: save-cross save-cross ;
: save-region save-region ;	: save-region save-region ;

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

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