version 1.4, 1998/12/08 22:03:09
|
version 1.13, 2002/09/24 17:57:29
|
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 -- ) |
: <resolve ( addr -- ) here - , ; |
here swap ! |
|
basic-block-end ; |
|
: <resolve ( addr -- ) , ; |
|
|
: BUT |
: BUT |
1 cs-roll ; immediate restrict |
1 cs-roll ; immediate restrict |
Line 118 variable backedge-locals
|
Line 122 variable backedge-locals
|
\ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
|
|
: AHEAD ( compilation -- orig ; run-time -- ) \ tools-ext |
: AHEAD ( compilation -- orig ; run-time -- ) \ tools-ext |
POSTPONE branch >mark POSTPONE unreachable ; immediate restrict |
POSTPONE abranch >mark POSTPONE unreachable ; immediate restrict |
|
|
: IF ( compilation -- orig ; run-time f -- ) \ core |
: IF ( compilation -- orig ; run-time f -- ) \ core |
POSTPONE ?branch >mark ; immediate restrict |
POSTPONE a?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 a?dup-?branch >mark ; immediate restrict |
|
|
: ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if |
: ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if |
POSTPONE ?dup-0=-?branch >mark ; immediate restrict |
POSTPONE a?dup-0=-?branch >mark ; immediate restrict |
|
|
Defer then-like ( orig -- ) |
Defer then-like ( orig -- ) |
: cs>addr ( orig/dest -- ) drop >resolve drop ; |
: cs>addr ( orig/dest -- ) drop >resolve drop ; |
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 |
|
basic-block-end ; immediate restrict |
|
|
Defer again-like ( dest -- addr ) |
Defer again-like ( dest -- addr ) |
' nip IS again-like |
' nip IS again-like |
|
|
: 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 abranch <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? ['] a?branch ['] a?branch-lp+!# until-like ; immediate restrict |
|
|
: WHILE ( compilation dest -- orig dest ; run-time f -- ) \ core |
: WHILE ( compilation dest -- orig dest ; run-time f -- ) \ core |
POSTPONE if |
POSTPONE if |
Line 245 Avariable leave-sp leave-stack 3 cells
|
Line 251 Avariable leave-sp leave-stack 3 cells
|
POSTPONE begin drop do-dest ; |
POSTPONE begin drop do-dest ; |
|
|
: ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext question-do |
: ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext question-do |
POSTPONE (?do) ?do-like ; immediate restrict |
POSTPONE a(?do) ?do-like ; immediate restrict |
|
|
: +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth plus-do |
: +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth plus-do |
POSTPONE (+do) ?do-like ; immediate restrict |
POSTPONE a(+do) ?do-like ; immediate restrict |
|
|
: U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-plus-do |
: U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-plus-do |
POSTPONE (u+do) ?do-like ; immediate restrict |
POSTPONE a(u+do) ?do-like ; immediate restrict |
|
|
: -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth minus-do |
: -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth minus-do |
POSTPONE (-do) ?do-like ; immediate restrict |
POSTPONE a(-do) ?do-like ; immediate restrict |
|
|
: U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-minus-do |
: U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-minus-do |
POSTPONE (u-do) ?do-like ; immediate restrict |
POSTPONE a(u-do) ?do-like ; immediate restrict |
|
|
: FOR ( compilation -- do-sys ; run-time u -- loop-sys ) \ gforth |
: FOR ( compilation -- do-sys ; run-time u -- loop-sys ) \ gforth |
POSTPONE (for) |
POSTPONE (for) |
Line 271 Avariable leave-sp leave-stack 3 cells
|
Line 277 Avariable leave-sp leave-stack 3 cells
|
until-like POSTPONE done POSTPONE unloop ; |
until-like POSTPONE done POSTPONE unloop ; |
|
|
: LOOP ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ core |
: LOOP ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ core |
['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict |
['] a(loop) ['] a(loop)-lp+!# loop-like ; immediate restrict |
|
|
: +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ core plus-loop |
: +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ core plus-loop |
['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict |
['] a(+loop) ['] a(+loop)-lp+!# loop-like ; immediate restrict |
|
|
\ !! should the compiler warn about +DO..-LOOP? |
\ !! should the compiler warn about +DO..-LOOP? |
: -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 ) \ gforth minus-loop |
: -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 ) \ gforth minus-loop |
['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict |
['] a(-loop) ['] a(-loop)-lp+!# loop-like ; immediate restrict |
|
|
\ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" |
\ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" |
\ will iterate as often as "high low ?DO inc S+LOOP". For positive |
\ will iterate as often as "high low ?DO inc S+LOOP". For positive |
\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for |
\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for |
\ negative increments. |
\ negative increments. |
: S+LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ gforth s-plus-loop |
: S+LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ gforth s-plus-loop |
['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict |
['] a(s+loop) ['] a(s+loop)-lp+!# loop-like ; immediate restrict |
|
|
: NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth |
: NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth |
['] (next) ['] (next)-lp+!# loop-like ; immediate restrict |
['] a(next) ['] a(next)-lp+!# loop-like ; immediate restrict |
|
|
\ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
|
|
Line 296 Defer exit-like ( -- )
|
Line 302 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 |
|
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 |