gforth/cross.fs - diff

Return to cross.fs CVS log

Up to [gforth] / gforth

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

version 1.52, 1997/08/31 19:31:28	version 1.53, 1997/09/13 12:04:55
Line 128 false DefaultValue create-forward-warn	Line 128 false DefaultValue create-forward-warn

previous >CROSS	previous >CROSS

	: .dec
	base @ decimal swap . base ! ;

: .sourcepos	: .sourcepos
cr sourcefilename type ." :"	cr sourcefilename type ." :"
base @ decimal sourceline# . base ! ;	sourceline# .dec ;

: warnhead	: warnhead
\G display error-message head	\G display error-message head
Line 274 VARIABLE env-current \ save information	Line 277 VARIABLE env-current \ save information

: e? name T environment? H 0= ABORT" environment variable not defined!" ;	: e? name T environment? H 0= ABORT" environment variable not defined!" ;

: has? name T environment? H IF ELSE false THEN ;	: has? name T environment? H
	IF \ environment variable is present, return its value
	ELSE \ environment variable is not present, return false
	\ !! JAW abort is just for testing
	false true ABORT" arg"
	THEN ;

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

>ENVIRON	>ENVIRON
true Value cross	false SetValue ionly
	true SetValue cross
>TARGET	>TARGET

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

>TARGET	>ENVIRON

	s" interpreter" T environment? H 0= ?dup nip [IF] true Value interpreter [THEN]
	s" ITC" T environment? H 0= ?dup nip [IF] true SetValue ITC [THEN]
	s" rom" T environment? H 0= ?dup nip [IF] false Value rom [THEN]

[IFUNDEF] has-interpreter true Value has-interpreter [THEN]	>TARGET
[IFUNDEF] itc true Value itc [THEN]	s" relocate" T environment? H
[IFUNDEF] has-rom false Value has-rom [THEN]	[IF] SetValue NIL
	[ELSE] >ENVIRON T NIL H SetValue relocate
	[THEN]

>CROSS	>CROSS

Line 406 Variable mirrored-link \ linked	Line 421 Variable mirrored-link \ linked
." End: " r@ 1 cells + @ + .addr space	." End: " r@ 1 cells + @ + .addr space
." DP: " r> 2 cells + @ .addr	." DP: " r> 2 cells + @ .addr
REPEAT drop	REPEAT drop
s" rom" $has? 0= ?EXIT	s" rom" T $has? H 0= ?EXIT
cr ." Mirrored:"	cr ." Mirrored:"
mirrored-link @	mirrored-link @
BEGIN dup	BEGIN dup
Line 422 Variable mirrored-link \ linked	Line 437 Variable mirrored-link \ linked
0 0 region dictionary	0 0 region dictionary
\ rom area for the compiler	\ rom area for the compiler

has? rom	T has? rom H
[IF]	[IF]
0 0 region ram-dictionary mirrored	0 0 region ram-dictionary mirrored
\ ram area for the compiler	\ ram area for the compiler
Line 440 has? rom	Line 455 has? rom


: setup-target ( -- ) \G initialize targets memory space	: setup-target ( -- ) \G initialize targets memory space
s" rom" $has?	s" rom" T $has? H
IF \ check for ram and rom...	IF \ check for ram and rom...
address-space area nip	address-space area nip
ram-dictionary area nip	ram-dictionary area nip
Line 493 variable fixed \ flag: true: no automat	Line 508 variable fixed \ flag: true: no automat
variable constflag constflag off	variable constflag constflag off

: (switchram)	: (switchram)
fixed @ ?EXIT has-rom 0= ?EXIT	fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT
ram-dictionary >rdp to tdp ;	ram-dictionary >rdp to tdp ;

: switchram	: switchram
Line 674 DEFER comp[ \ ends compilation	Line 689 DEFER comp[ \ ends compilation
: compile, colon, ;	: compile, colon, ;
>CROSS	>CROSS

	\ file loading

	Variable filelist 0 filelist !
	0 Value loadfile

	0 [IF] \ !! JAW WIP

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

	: included? ( c-addr u -- f )
	filelist
	BEGIN @ dup
	WHILE >r r@ 1 cells + count compare 0=
	IF rdrop 2drop true EXIT THEN
	r>
	REPEAT
	2drop drop false ;

	: included
	cr ." Including: " 2dup type ." ..."
	2dup add-included-file included ;

	: include bl word count included ;

	: require bl word count included ;

	[THEN]

\ 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
: >taddr cell+ cell+ ;	: >taddr cell+ cell+ ;
: >ghost 3 cells + ;	: >ghost 3 cells + ;
	: >file 4 cells + ;
	: >line 5 cells + ;

: refered ( ghost tag -- )	: refered ( ghost tag -- )
	\G creates a resolve structure
swap >r here r@ >link @ , r@ >link ! ( tag ) ,	swap >r here r@ >link @ , r@ >link ! ( tag ) ,
T here aligned H , r> drop last-header-ghost @ , ;	T here aligned H , r> drop last-header-ghost @ ,
	loadfile , sourceline# ,
	;

Defer resolve-warning	Defer resolve-warning

Line 768 variable ResolveFlag	Line 818 variable ResolveFlag
: ?touched ( ghost -- flag ) dup forward? swap >link @	: ?touched ( ghost -- flag ) dup forward? swap >link @
0 <> and ;	0 <> and ;

	: .forwarddefs ( ghost -- )
	." appeared in:"
	>link
	BEGIN @ dup
	WHILE cr 5 spaces
	dup >ghost @ >ghostname type
	." file " dup >file @ ?dup IF count type ELSE ." CON" THEN
	." line " dup >line @ .dec
	REPEAT
	drop ;

: ?resolved ( ghostname -- )	: ?resolved ( ghostname -- )
dup cell+ @ ?touched	dup cell+ @ ?touched
IF cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ;	IF dup
	cell+ cell+ count cr type ResolveFlag on
	cell+ @ .forwarddefs
	ELSE drop
	THEN ;

>MINIMAL	>MINIMAL
: .unresolved ( -- )	: .unresolved ( -- )
Line 789 variable ResolveFlag	Line 854 variable ResolveFlag
: .stats	: .stats
base @ >r decimal	base @ >r decimal
cr ." named Headers: " headers-named @ .	cr ." named Headers: " headers-named @ .
\ cr ." MaxRam*" ramdp @ .
\ cr ." MaxRom*" romdp @ .
r> base ! ;	r> base ! ;

>CROSS	>CROSS
Line 958 VARIABLE ;Resolve 1 cells allot	Line 1021 VARIABLE ;Resolve 1 cells allot
>TARGET	>TARGET
: Alias ( cfa -- ) \ name	: Alias ( cfa -- ) \ name
>in @ skip? IF 2drop EXIT THEN >in !	>in @ skip? IF 2drop EXIT THEN >in !
dup 0< has-prims 0= and	dup 0< s" prims" T $has? H 0= and
IF	IF
." needs prim: " >in @ bl word count type >in ! cr	.sourcepos ." needs prim: " >in @ bl word count type >in ! cr
THEN	THEN
(THeader over resolve T A, H 80 flag! ;	(THeader over resolve T A, H 80 flag! ;
: Alias: ( cfa -- ) \ name	: Alias: ( cfa -- ) \ name
>in @ skip? IF 2drop EXIT THEN >in !	>in @ skip? IF 2drop EXIT THEN >in !
dup 0< has-prims 0= and	dup 0< s" prims" T $has? H 0= and
IF	IF
." needs doer: " >in @ bl word count type >in ! cr	.sourcepos ." needs doer: " >in @ bl word count type >in ! cr
THEN	THEN
ghost tuck swap resolve <do:> swap >magic ! ;	ghost tuck swap resolve <do:> swap >magic ! ;
>CROSS	>CROSS
Line 1066 Defer (end-code)	Line 1129 Defer (end-code)
: Code	: Code
defempty?	defempty?
(THeader there resolve	(THeader there resolve
[ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF]	[ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]
doprim,	doprim,
[THEN]	[THEN]
depth (code) ;	depth (code) ;
Line 1268 Cond: DOES> restrict?	Line 1331 Cond: DOES> restrict?

: BuildSmart: ( -- [xt] [colon-sys] )	: BuildSmart: ( -- [xt] [colon-sys] )
:noname	:noname
[ has-rom [IF] ]	[ T has? rom H [IF] ]
postpone RTCreate	postpone RTCreate
[ [ELSE] ]	[ [ELSE] ]
postpone TCreate	postpone TCreate
Line 1320 BuildSmart: ;	Line 1383 BuildSmart: ;
by: :dovar ( ghost -- addr ) ;DO	by: :dovar ( ghost -- addr ) ;DO
Builder Create	Builder Create

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

has-rom [IF]	T has? rom H [IF]
Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;	Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ;
by (Constant)	by (Constant)
Builder AVariable	Builder AVariable
Line 1504 Cond: NEXT restrict? sys? compile (	Line 1567 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]
>CROSS	>CROSS
Variable tleavings	Variable tleavings
>TARGET	>TARGET
Line 1519 Cond: DONE ( addr -- ) restrict? tlea	Line 1583 Cond: DONE ( addr -- ) restrict? tlea
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]
	\ !! This is WIP
	\ The problem is (?DO)!
	\ perhaps we need a plug-in for (?DO)

	>CROSS
	Variable tleavings 0 tleavings !
	>TARGET

	Cond: DONE ( addr -- )
	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
	: (leave ( branchtoken -- )
	3 cells allocate throw >r
	T here H r@ cell+ !
	r@ 2 cells + !
	tleavings @ r@ !
	r> tleavings ! ;
	>TARGET

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

	[THEN]

\ Structural Conditionals 12dec92py	\ Structural Conditionals 12dec92py

	>TARGET
Cond: AHEAD restrict? branchmark, ;Cond	Cond: AHEAD restrict? branchmark, ;Cond
Cond: IF restrict? ?branchmark, ;Cond	Cond: IF restrict? ?branchmark, ;Cond
Cond: THEN restrict? sys? branchto, branchtoresolve, ;Cond	Cond: THEN restrict? sys? branchto, branchtoresolve, ;Cond
Line 1545 Cond: ?DO restrict? compile (?do)	Line 1645 Cond: ?DO restrict? compile (?do)
Cond: FOR restrict? compile (for) T here H ;Cond	Cond: FOR restrict? compile (for) T here H ;Cond

>CROSS	>CROSS
: loop] dup <resolve tcell - compile DONE compile unloop ;	: loop] branchto, 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

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

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