version 1.7, 1999/12/03 18:49:51
|
version 1.22, 2007/12/31 18:40:26
|
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,2003,2004,2007 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
\ Gforth is free software; you can redistribute it and/or |
\ Gforth is free software; you can redistribute it and/or |
\ modify it under the terms of the GNU General Public License |
\ modify it under the terms of the GNU General Public License |
\ as published by the Free Software Foundation; either version 2 |
\ as published by the Free Software Foundation, either version 3 |
\ of the License, or (at your option) any later version. |
\ of the License, or (at your option) any later version. |
|
|
\ This program is distributed in the hope that it will be useful, |
\ This program is distributed in the hope that it will be useful, |
Line 15
|
Line 15
|
\ GNU General Public License for more details. |
\ GNU General Public License for more details. |
|
|
\ 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, see http://www.gnu.org/licenses/. |
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, 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 105 variable backedge-locals
|
Line 104 variable backedge-locals
|
|
|
\ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
|
|
|
defer other-control-flow ( -- ) |
|
\ hook for control-flow stuff that's not handled by begin-like etc. |
|
|
: ?struc ( flag -- ) abort" unstructured " ; |
: ?struc ( flag -- ) abort" unstructured " ; |
: sys? ( sys -- ) dup 0= ?struc ; |
: sys? ( sys -- ) dup 0= ?struc ; |
: >mark ( -- orig ) |
: >mark ( -- orig ) |
cs-push-orig 0 , ; |
cs-push-orig 0 , other-control-flow ; |
: >resolve ( addr -- ) here over - swap ! ; |
: >resolve ( addr -- ) |
: <resolve ( addr -- ) here - , ; |
here swap ! |
|
basic-block-end ; |
|
: <resolve ( addr -- ) , ; |
|
|
: BUT |
: BUT |
1 cs-roll ; immediate restrict |
1 cs-roll ; immediate restrict |
Line 146 immediate restrict
|
Line 150 immediate restrict
|
\ people who have not been brought up with Forth (or who have been |
\ people who have not been brought up with Forth (or who have been |
\ brought up with fig-Forth). |
\ brought up with fig-Forth). |
|
|
: ELSE ( compilation orig1 -- orig2 ; run-time f -- ) \ core |
: ELSE ( compilation orig1 -- orig2 ; run-time -- ) \ core |
POSTPONE ahead |
POSTPONE ahead |
1 cs-roll |
1 cs-roll |
POSTPONE then ; immediate restrict |
POSTPONE then ; immediate restrict |
Line 155 Defer begin-like ( -- )
|
Line 159 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 |
|
basic-block-end ; immediate restrict |
|
|
Defer again-like ( dest -- addr ) |
Defer again-like ( dest -- addr ) |
' nip IS again-like |
' nip IS again-like |
Line 163 Defer again-like ( dest -- addr )
|
Line 168 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 298 Defer exit-like ( -- )
|
Line 304 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 Return to the calling definition; usually used as a way of |
\G forcing an early return from a definition. Before |
\G forcing an early return from a definition. Before |
\G @code{EXIT}ing you must clean up the return stack and |
\G @code{EXIT}ing you must clean up the return stack and |
\G @code{UNLOOP} any outstanding @code{?DO}...@code{LOOP}s. |
\G @code{UNLOOP} any outstanding @code{?DO}...@code{LOOP}s. |
exit-like |
exit-like |
POSTPONE ;s |
POSTPONE ;s |
|
basic-block-end |
POSTPONE unreachable ; immediate restrict |
POSTPONE unreachable ; immediate restrict |
|
|
: ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth |
: ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth |