version 1.2, 1998/10/10 10:28:36
|
version 1.9, 2000/09/23 15:06:09
|
Line 1
|
Line 1
|
\ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
|
|
\ Copyright (C) 1995-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 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 |
dup cs-item? ; |
dup cs-item? ; |
|
|
: cs-push-part ( -- list addr ) |
: cs-push-part ( -- list addr ) |
locals-list wordlist-id @ here ; |
locals-list @ here ; |
|
|
: cs-push-orig ( -- orig ) |
: cs-push-orig ( -- orig ) |
cs-push-part dead-code @ |
cs-push-part dead-code @ |
Line 124 variable backedge-locals
|
Line 126 variable backedge-locals
|
POSTPONE ?branch >mark ; immediate restrict |
POSTPONE ?branch >mark ; immediate restrict |
|
|
: ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-if |
: ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-if |
\G This is the preferred alternative to the idiom "?DUP IF", since it can be |
\G This is the preferred alternative to the idiom "@code{?DUP IF}", since it can be |
\G better handled by tools like stack checkers. Besides, it's faster. |
\G better handled by tools like stack checkers. Besides, it's faster. |
POSTPONE ?dup-?branch >mark ; immediate restrict |
POSTPONE ?dup-?branch >mark ; immediate restrict |
|
|
Line 161 Defer again-like ( dest -- addr )
|
Line 163 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 |
Line 296 Defer exit-like ( -- )
|
Line 299 Defer exit-like ( -- )
|
' noop IS exit-like |
' noop IS exit-like |
|
|
: EXIT ( compilation -- ; run-time nest-sys -- ) \ core |
: EXIT ( compilation -- ; run-time nest-sys -- ) \ core |
|
\G Return to the calling definition; usually used as a way of |
|
\G forcing an early return from a definition. Before |
|
\G @code{EXIT}ing you must clean up the return stack and |
|
\G @code{UNLOOP} any outstanding @code{?DO}...@code{LOOP}s. |
exit-like |
exit-like |
POSTPONE ;s |
POSTPONE ;s |
POSTPONE unreachable ; immediate restrict |
POSTPONE unreachable ; immediate restrict |