Diff for /gforth/kernel/cond.fs between versions 1.1 and 1.13

version 1.1, 1997/05/21 20:40:14 version 1.13, 2002/09/24 17:57:29
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 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

Removed from v.1.1  
changed lines
  Added in v.1.13


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