gforth/cross.fs - diff

Return to cross.fs CVS log

Up to [gforth] / gforth

Diff for /gforth/cross.fs between versions 1.47 and 1.48

version 1.47, 1997/04/10 21:32:08	version 1.48, 1997/05/21 20:39:21
Line 37	Line 37
\ targets 09jun93jaw	\ targets 09jun93jaw
\ added: 2user and value 11jun93jaw	\ added: 2user and value 11jun93jaw

	\ needed? works better now!!! 01mar97jaw
	\ mach file is only loaded into target
	\ cell corrected


\ include other.fs \ ansforth extentions for cross	\ include other.fs \ ansforth extentions for cross

: string, ( c-addr u -- )	: string, ( c-addr u -- )
Line 93 H	Line 98 H

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

	>TARGET
mach-file count included	mach-file count included

	[IFUNDEF] has-interpreter true CONSTANT has-interpreter [THEN]

also Forth definitions	also Forth definitions

[IFDEF] asm-include asm-include [THEN]	[IFDEF] asm-include asm-include [THEN]
Line 104 hex	Line 112 hex

>CROSS	>CROSS

\ Variables 06oct92py

Variable image
Variable tlast NIL tlast ! \ Last name field
Variable tlastcfa \ Last code field
Variable tdoes \ Resolve does> calls
Variable bit$
Variable tdp
: there tdp @ ;

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

T	T
	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
Line 125 float Constant tfloat	Line 124 float Constant tfloat
1 bits/byte lshift Constant maxbyte	1 bits/byte lshift Constant maxbyte
H	H

	\ Variables 06oct92py

	Variable image
	Variable tlast TNIL tlast ! \ Last name field
	Variable tlastcfa \ Last code field
	Variable tdoes \ Resolve does> calls
	Variable bit$
	Variable tdp
	: there tdp @ ;


>TARGET	>TARGET

\ Byte ordering and cell size 06oct92py	\ Byte ordering and cell size 06oct92py
Line 132 H	Line 142 H
: cell+ tcell + ;	: cell+ tcell + ;
: cells tcell<< lshift ;	: cells tcell<< lshift ;
: chars ;	: chars ;
	: char+ 1 + ;
: floats tfloat * ;	: floats tfloat * ;

>CROSS	>CROSS
: cell/ tcell<< rshift ;	: cell/ tcell<< rshift ;
>TARGET	>TARGET
20 CONSTANT bl	20 CONSTANT bl
-1 Constant NIL	TNIL Constant NIL

>CROSS	>CROSS

Line 174 bigendian	Line 185 bigendian

>MINIMAL	>MINIMAL
: makekernel ( targetsize -- targetsize )	: makekernel ( targetsize -- targetsize )
bit$ over 1- cell>bit rshift 1+ initmem	bit$ over 1- tcell>bit rshift 1+ initmem
image over initmem tdp off ;	image over initmem tdp off ;

>CROSS	>CROSS
Line 192 CREATE Bittable 80 c, 40 c, 20 c, 10 c,	Line 203 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
\ Target memory access 06oct92py	\ Target memory access 06oct92py

: align+ ( taddr -- rest )	: align+ ( taddr -- rest )
cell tuck 1- and - [ cell 1- ] Literal and ;	tcell tuck 1- and - [ tcell 1- ] Literal and ;
: cfalign+ ( taddr -- rest )	: cfalign+ ( taddr -- rest )
\ see kernel.fs:cfaligned	\ see kernel.fs:cfaligned
/maxalign tuck 1- and - [ /maxalign 1- ] Literal and ;	/maxalign tuck 1- and - [ /maxalign 1- ] Literal and ;
Line 220 CREATE Bittable 80 c, 40 c, 20 c, 10 c,	Line 231 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 cell T allot ! H ;	: , ( w -- ) T here H tcell T allot ! H ;
: c, ( char -- ) T here 1 allot c! H ;	: c, ( char -- ) T here 1 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 ( -- )
Line 271 Variable last-ghost	Line 282 Variable last-ghost
here tuck swap ! ghostheader T>	here tuck swap ! ghostheader T>
DOES> dup last-ghost ! >exec @ execute ;	DOES> dup last-ghost ! >exec @ execute ;

	variable cfalist 0 cfalist !

	: markcfa
	cfalist here over @ , swap ! , ;

\ ghost words 14oct92py	\ ghost words 14oct92py
\ changed: 10may93py/jaw	\ changed: 10may93py/jaw

Line 340 variable ResolveFlag	Line 356 variable ResolveFlag
WHILE dup ?resolved	WHILE dup ?resolved
REPEAT drop ResolveFlag @	REPEAT drop ResolveFlag @
IF	IF
abort" Unresolved words!"	-1 abort" Unresolved words!"
ELSE	ELSE
." Nothing!"	." Nothing!"
THEN	THEN
Line 376 VARIABLE ^imm	Line 392 VARIABLE ^imm

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

s" 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 443 Defer skip? ' false IS skip?	Line 459 Defer skip? ' false IS skip?
ghost >magic @ <fwd> <> ;	ghost >magic @ <fwd> <> ;

: needed? ( -- flag ) \ name	: needed? ( -- flag ) \ name
ghost dup >magic @ <fwd> =	\G returns a false flag when
IF >link @ 0<> ELSE drop false THEN ;	\G a word is not defined
	\G a forward reference exists
	\G so the definition is not skipped!
	bl word gfind
	IF dup >magic @ <fwd> =
	\ swap >link @ 0<> and
	nip
	0=
	ELSE drop true THEN ;

: doer? ( -- flag ) \ name	: doer? ( -- flag ) \ name
ghost >magic @ <do:> = ;	ghost >magic @ <do:> = ;
Line 552 Defer (code)	Line 576 Defer (code)
Defer (end-code)	Defer (end-code)
[THEN]	[THEN]

	[IFUNDEF] ca>native
	defer ca>native
	[THEN]

>TARGET	>TARGET
: Code	: Code
(THeader there resolve	(THeader there resolve
[ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF]	[ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF]
there 2 T cells H + T a, 0 , H	there 2 T cells H + ca>native T a, 0 , H
[THEN]	[THEN]
depth (code) ;	depth (code) ;

: Code:	: Code:
ghost dup there resolve <do:> swap >magic !	ghost dup there ca>native resolve <do:> swap >magic !
depth (code) ;	depth (code) ;

: end-code	: end-code
Line 673 Cond: [ restrict? state off ;Cond	Line 701 Cond: [ restrict? state off ;Cond

>TARGET	>TARGET
Cond: DOES> restrict?	Cond: DOES> restrict?
compile (does>) dodoes, tdoes @ ?dup IF @ T here H resolve THEN	compile (does>) dodoes, tdoes @ ?dup IF @ T here H resolve THEN
;Cond	;Cond
: DOES> dodoes, T here H !does depth T ] H ;	: DOES> dodoes, T here H !does depth T ] H ;

Line 878 Cond: ENDCASE restrict? compile drop 0	Line 906 Cond: ENDCASE restrict? compile drop 0
\ Structural Conditionals 12dec92py	\ Structural Conditionals 12dec92py

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

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

Cond: LOOP restrict? sys? compile (loop) loop] ;Cond	Cond: LOOP restrict? sys? compile (loop) loop] ;Cond
Line 962 also minimal	Line 990 also minimal

also minimal	also minimal

	\G interprets the line if word is not defined
: \- defined? IF postpone \ THEN ;	: \- defined? IF postpone \ THEN ;

	\G interprets the line if word is defined
: \+ defined? 0= IF postpone \ THEN ;	: \+ defined? 0= IF postpone \ THEN ;

	Cond: \- \- ;Cond
	Cond: \+ \+ ;Cond

	: ?? bl word find IF execute ELSE drop 0 THEN ;

	: needed:
	\G defines ghost for words that we want to be compiled
	BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;

: [IF] postpone [IF] ;	: [IF] postpone [IF] ;
: [THEN] postpone [THEN] ;	: [THEN] postpone [THEN] ;
: [ELSE] postpone [ELSE] ;	: [ELSE] postpone [ELSE] ;
Line 975 Cond: [IFUNDEF] [IFUNDEF] ;Cond	Line 1015 Cond: [IFUNDEF] [IFUNDEF] ;Cond
Cond: [THEN] [THEN] ;Cond	Cond: [THEN] [THEN] ;Cond
Cond: [ELSE] [ELSE] ;Cond	Cond: [ELSE] [ELSE] ;Cond

\ save-cross 17mar93py	previous

\ i'm not interested in bigforth features this time 10may93jaw
\ [IFDEF] file
\ also file
\ [THEN]
\ included throw after create-file 11may93jaw

bigendian Constant bigendian	\ save-cross 17mar93py

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

char 1 bigendian + cell + magic 7 + c!	char 1 bigendian + tcell + 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
NIL IF	TNIL IF
s" #! " r@ write-file throw	s" #! " r@ write-file throw
bl parse r@ write-file throw	bl parse r@ write-file throw
s" -i" r@ write-file throw	s" -i" r@ write-file throw
Line 1007 char 1 bigendian + cell + magic 7 + c!	Line 1042 char 1 bigendian + cell + magic 7 + c!
bl parse 2drop	bl parse 2drop
THEN	THEN
image @ there r@ write-file throw \ write image	image @ there r@ write-file throw \ write image
NIL IF	TNIL IF
bit$ @ there 1- cell>bit rshift 1+	bit$ @ there 1- tcell>bit rshift 1+
r@ write-file throw \ write tags	r@ write-file throw \ write tags
THEN	THEN
r> close-file throw ;	r> close-file throw ;

\ words that should be in minimal	\ words that should be in minimal
	>MINIMAL
	also minimal

	bigendian Constant bigendian
	: save-cross save-cross ;
: here there ;	: here there ;
also forth [IFDEF] Label : Label Label ; [THEN] previous	also forth
	[IFDEF] Label : Label Label ; [THEN]
	[IFDEF] start-macros : start-macros start-macros ; [THEN]
	previous

: + + ;	: + + ;
: or or ;	: or or ;
: 1- 1- ;	: 1- 1- ;
Line 1035 also forth [IFDEF] Label : Label Label ;	Line 1078 also forth [IFDEF] Label : Label Label ;
: 2/ 2/ ;	: 2/ 2/ ;
: . . ;	: . . ;

mach-file count included	\ mach-file count included

: all-words ['] false IS skip? ;	: all-words ['] false IS skip? ;
: needed-words ['] needed? IS skip? ;	: needed-words ['] needed? IS skip? ;

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

Removed from v.1.47
changed lines
	Added in v.1.48