gforth/cross.fs - diff

Return to cross.fs CVS log

Up to [gforth] / gforth

Diff for /gforth/cross.fs between versions 1.72 and 1.75

version 1.72, 1999/02/22 19:05:45	version 1.75, 1999/05/10 13:57:37
Line 58 Warnings off	Line 58 Warnings off
\ we have to set current to be topmost context wordlist	\ we have to set current to be topmost context wordlist
get-order get-order get-current swap 1+ set-order	get-order get-order get-current swap 1+ set-order
r> ['] to execute	r> ['] to execute
set-order order	set-order
ELSE Value THEN ;	ELSE Value THEN ;

: DefaultValue ( n -- <name> )	: DefaultValue ( n -- <name> )
Line 118 also forth definitions \ these values m	Line 118 also forth definitions \ these values m
false DefaultValue stack-warn \ check on empty stack at any definition	false DefaultValue stack-warn \ check on empty stack at any definition
false DefaultValue create-forward-warn \ warn on forward declaration of created words	false DefaultValue create-forward-warn \ warn on forward declaration of created words

[IFUNDEF] DebugMaskSrouce Variable DebugMaskSource 0 DebugMaskSource ! [THEN]
[IFUNDEF] DebugMaskCross Variable DebugMaskCross 0 DebugMaskCross ! [THEN]


previous >CROSS	previous >CROSS

Line 143 stack-warn [IF]	Line 144 stack-warn [IF]
: defempty? ; immediate	: defempty? ; immediate
[THEN]	[THEN]

	\ debugging

	0 [IF]

	This implements debugflags for the cross compiler and the compiled
	images. It works identical to the has-flags in the environment.
	The debugflags are defined in a vocabluary. If the word exists and
	its value is true, the flag is switched on.

	[THEN]

	Vocabulary debugflags \ debug flags for cross
	also debugflags get-order over
	Constant debugflags-wl
	set-order previous

	: DebugFlag
	get-current >r debugflags-wl set-current
	SetValue
	r> set-current ;

	: Debug? ( adr u -- flag )
	\G return true if debug flag is defined or switched on
	debugflags-wl search-wordlist
	IF EXECUTE
	ELSE false THEN ;

	: D? ( <name> -- flag )
	\G return true if debug flag is defined or switched on
	\G while compiling we do not return the current value but
	bl word count debug? ;

	: [d?]
	\G compile the value-xt so the debug flag can be switched
	\G the flag must exist!
	bl word count debugflags-wl search-wordlist
	IF compile,
	ELSE -1 ABORT" unknown debug flag"
	\ POSTPONE false
	THEN ; immediate

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

Line 171 VARIABLE VocTemp	Line 211 VARIABLE VocTemp
hex	hex
4711 Constant <fwd> 4712 Constant <res>	4711 Constant <fwd> 4712 Constant <res>
4713 Constant <imm> 4714 Constant <do:>	4713 Constant <imm> 4714 Constant <do:>
	4715 Constant <skip>

\ iForth makes only immediate directly after create	\ iForth makes only immediate directly after create
\ make atonce trick! ?	\ make atonce trick! ?
Line 240 VARIABLE Already	Line 281 VARIABLE Already
: forward? ( ghost -- flag )	: forward? ( ghost -- flag )
>magic @ <fwd> = ;	>magic @ <fwd> = ;

	: undefined? ( ghost -- flag )
	>magic @ dup <fwd> = swap <skip> = or ;

\ Predefined ghosts 12dec92py	\ Predefined ghosts 12dec92py

ghost 0= drop	ghost 0= drop
Line 281 VARIABLE env-current \ save information	Line 325 VARIABLE env-current \ save information
: has? bl word count T environment? H	: has? bl word count T environment? H
IF \ environment variable is present, return its value	IF \ environment variable is present, return its value
ELSE \ environment variable is not present, return false	ELSE \ environment variable is not present, return false
\ !! JAW abort is just for testing	false \ debug true ABORT" arg"
false true ABORT" arg"
THEN ;	THEN ;

: $has? T environment? H IF ELSE false THEN ;	: $has? T environment? H IF ELSE false THEN ;
Line 315 false DefaultValue header	Line 358 false DefaultValue header
true DefaultValue interpreter	true DefaultValue interpreter
true DefaultValue ITC	true DefaultValue ITC
false DefaultValue rom	false DefaultValue rom
	true DefaultValue standardthreading

>TARGET	>TARGET
s" relocate" T environment? H	s" relocate" T environment? H
Line 747 T has? relocate H	Line 791 T has? relocate H
\ \ Load Assembler	\ \ Load Assembler

>TARGET	>TARGET
H also Forth definitions \ ." asm: " order	H also Forth definitions

: X also target bl word find	: X also target bl word find
IF state @ IF compile,	IF state @ IF compile,
Line 865 Create NoFile ," #load-file#"	Line 909 Create NoFile ," #load-file#"
REPEAT	REPEAT
2drop drop false ;	2drop drop false ;

	false DebugFlag showincludedfiles

: included	: included
\ cr ." Including: " 2dup type ." ..."	[d?] showincludedfiles
	IF cr ." Including: " 2dup type ." ..." THEN
FileMem >r	FileMem >r
2dup add-included-file included	2dup add-included-file included
r> to FileMem ;	r> to FileMem ;
Line 969 Exists-Warnings on	Line 1016 Exists-Warnings on
\G resolve referencies to ghost with tcfa	\G resolve referencies to ghost with tcfa
\ is ghost resolved?, second resolve means another definition with the	\ is ghost resolved?, second resolve means another definition with the
\ same name	\ same name
over forward? 0= IF exists EXIT THEN	over undefined? 0= IF exists EXIT THEN
\ get linked-list	\ get linked-list
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
Line 1146 Create tag-bof 1 c, 0C c,	Line 1193 Create tag-bof 1 c, 0C c,

Defer skip? ' false IS skip?	Defer skip? ' false IS skip?

	: skipdef ( <name> -- )
	\G skip definition of an undefined word in undef-words mode
	ghost dup forward?
	IF >magic <skip> swap !
	ELSE drop THEN ;

: defined? ( -- flag ) \ name	: defined? ( -- flag ) \ name
	ghost undefined? 0= ;

	: defined2? ( -- flag ) \ name
	\G return true for anything else than forward, even for <skip>
	\G that's what we want
ghost forward? 0= ;	ghost forward? 0= ;

: needed? ( -- flag ) \ name	: needed? ( -- flag ) \ name
Line 1155 Defer skip? ' false IS skip?	Line 1213 Defer skip? ' false IS skip?
\G a forward reference exists	\G a forward reference exists
\G so the definition is not skipped!	\G so the definition is not skipped!
bl word gfind	bl word gfind
IF dup forward?	IF dup undefined?
nip	nip
0=	0=
ELSE drop true THEN ;	ELSE drop true THEN ;
Line 1288 Comment ( Comment \	Line 1346 Comment ( Comment \
THEN ; immediate	THEN ; immediate

: ghost>cfa	: ghost>cfa
dup forward? ABORT" CROSS: forward " >link @ ;	dup undefined? ABORT" CROSS: forward " >link @ ;

>TARGET	>TARGET

Line 1522 Cond: DOES> restrict?	Line 1580 Cond: DOES> restrict?

: gdoes, ( ghost -- )	: gdoes, ( ghost -- )
\ makes the codefield for a word that is built	\ makes the codefield for a word that is built
>end @ dup forward? 0=	>end @ dup undefined? 0=
IF	IF
dup >magic @ <do:> =	dup >magic @ <do:> =
IF doer,	IF doer,
Line 2019 Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond	Line 2077 Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond

also minimal	also minimal

\G doesn't skip line when bit is set in debugmask	: d? d? ;
: \D name evaluate debugmasksource @ and 0= IF postpone \ THEN ;
	\G doesn't skip line when debug switch is on
	: \D D? 0= IF postpone \ THEN ;

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

: all-words ['] false IS skip? ;	: all-words ['] false IS skip? ;
: needed-words ['] needed? IS skip? ;	: needed-words ['] needed? IS skip? ;
: undef-words ['] defined? IS skip? ;	: undef-words ['] defined2? IS skip? ;
	: skipdef skipdef ;

: \ postpone \ ; immediate	: \ postpone \ ; immediate
: \G T-\G ; immediate	: \G T-\G ; immediate
Line 2190 minimal	Line 2251 minimal
\ these ones are pefered:	\ these ones are pefered:

: lock turnkey ;	: lock turnkey ;
: unlock forth also cross ;	: unlock previous forth also cross ;

: [[ also unlock ;	: [[ also unlock ;
: ]] previous previous ;	: ]] previous previous ;

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

Removed from v.1.72
changed lines
	Added in v.1.75