gforth/kernel/cond.fs - diff

Return to cond.fs CVS log

Up to [gforth] / gforth / kernel

Diff for /gforth/kernel/cond.fs between versions 1.5 and 1.11

version 1.5, 1999/03/23 20:24:24	version 1.11, 2001/02/24 17:24:45
Line 1	Line 1
\ Structural Conditionals 12dec92py	\ Structural Conditionals 12dec92py

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

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

Line 16	Line 16

\ You should have received a copy of the GNU General Public License	\ You should have received a copy of the GNU General Public License
\ along with this program; if not, write to the Free Software	\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.	\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.

here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs	here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs
AConstant locals-list \ acts like a variable that contains	AConstant locals-list \ acts like a variable that contains
Line 48 variable backedge-locals	Line 48 variable backedge-locals
\ locals-list (valid at address) (third)	\ locals-list (valid at address) (third)

\ types	\ types
0 constant defstart	[IFUNDEF] defstart
	0 constant defstart \ usally defined in comp.fs
	[THEN]
1 constant live-orig	1 constant live-orig
2 constant dead-orig	2 constant dead-orig
3 constant dest \ the loopback branch is always assumed live	3 constant dest \ the loopback branch is always assumed live
Line 78 variable backedge-locals	Line 80 variable backedge-locals

3 constant cs-item-size	3 constant cs-item-size

: CS-PICK ( ... u -- ... destu ) \ tools-ext	: CS-PICK ( ... u -- ... destu ) \ tools-ext c-s-pick
1+ cs-item-size * 1- >r	1+ cs-item-size * 1- >r
r@ pick r@ pick r@ pick	r@ pick r@ pick r@ pick
rdrop	rdrop
dup non-orig? ;	dup non-orig? ;

: CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) \ tools-ext	: CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) \ tools-ext c-s-roll
1+ cs-item-size * 1- >r	1+ cs-item-size * 1- >r
r@ roll r@ roll r@ roll	r@ roll r@ roll r@ roll
rdrop	rdrop
Line 107 variable backedge-locals	Line 109 variable backedge-locals
: sys? ( sys -- ) dup 0= ?struc ;	: sys? ( sys -- ) dup 0= ?struc ;
: >mark ( -- orig )	: >mark ( -- orig )
cs-push-orig 0 , ;	cs-push-orig 0 , ;
: >resolve ( addr -- ) here over - swap ! ;	: >resolve ( addr -- )
	here over - swap !
	0 last-compiled ! ;
: <resolve ( addr -- ) here - , ;	: <resolve ( addr -- ) here - , ;

: BUT	: BUT
Line 153 Defer begin-like ( -- )	Line 157 Defer begin-like ( -- )
' noop IS begin-like	' noop IS begin-like

: BEGIN ( compilation -- dest ; run-time -- ) \ core	: BEGIN ( compilation -- dest ; run-time -- ) \ core
begin-like cs-push-part dest ; immediate restrict	begin-like cs-push-part dest
	0 last-compiled ! ; immediate restrict

Defer again-like ( dest -- addr )	Defer again-like ( dest -- addr )
' nip IS again-like	' nip IS again-like
Line 161 Defer again-like ( dest -- addr )	Line 166 Defer again-like ( dest -- addr )
: AGAIN ( compilation dest -- ; run-time -- ) \ core-ext	: AGAIN ( compilation dest -- ; run-time -- ) \ core-ext
dest? again-like POSTPONE branch <resolve ; immediate restrict	dest? again-like POSTPONE branch <resolve ; immediate restrict

Defer until-like	Defer until-like ( list addr xt1 xt2 -- )
: until, ( list addr xt1 xt2 -- ) drop compile, <resolve drop ;	:noname ( list addr xt1 xt2 -- )
' until, IS until-like	drop compile, <resolve drop ;
	IS until-like

: UNTIL ( compilation dest -- ; run-time f -- ) \ core	: UNTIL ( compilation dest -- ; run-time f -- ) \ core
dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict	dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict

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

Removed from v.1.5
changed lines
	Added in v.1.11