File:  [gforth] / gforth / compat / loops.fs
Revision 1.2: download - view: text, annotated - select for diffs
Mon Nov 11 17:00:07 1996 UTC (27 years, 4 months ago) by anton
Branches: MAIN
CVS tags: v0-3-0, v0-2-1, v0-2-0, HEAD
Added struct.fs, fixed loops.fs

    1: \ +DO, -DO...-LOOP and friends
    2: 
    3: \ This file is in the public domain. NO WARRANTY.
    4: 
    5: \ Hmm, this would be a good application for ]] ... [[
    6: 
    7: : +DO ( compile-time: -- do-sys; run-time: n1 n2 -- )
    8:     POSTPONE over POSTPONE min POSTPONE ?do ; immediate
    9: 
   10: : umin ( u1 u2 -- u )
   11:     2dup u>
   12:     IF
   13: 	swap
   14:     THEN
   15:     drop ;
   16: 
   17: : U+DO ( compile-time: -- do-sys; run-time: u1 u2 -- )
   18:     POSTPONE over POSTPONE umin POSTPONE ?do ; immediate
   19: 
   20: \ -DO...-LOOP
   21: 
   22: \ You have to use the -LOOP implemented below with -DO or U-DO, you
   23: \ cannot use it with ?DO
   24: 
   25: \ The implementation is a little more complicated. Basically, we
   26: \ create an IF DO ... +LOOP THEN structure. The DO..+LOOP does not
   27: \ exhibit the anomaly of ?DO...+LOOP; the IF..THEN is needed to
   28: \ correct for DO's at-least-once semantics. The parameters are
   29: \ conditioned a bit such that the result is as expected.
   30: 
   31: \ I define a '-do-sys' (whose implementation is 'orig do-sys'). Like
   32: \ ANS Forth loop structures, this implementation of -DO..-LOOP
   33: \ cannot be mixed with any other structures.
   34: 
   35: \ unlike Gforth's -LOOP, this implementation cannot handle all
   36: \ unsigned increments, only positive integers
   37: : -LOOP ( compilation -do-sys -- ; run-time loop-sys1 +n -- | loop-sys2 )
   38:     POSTPONE negate POSTPONE +loop
   39:     POSTPONE else POSTPONE 2drop POSTPONE then ; immediate
   40: 
   41: : -DO ( compilation -- -do-sys ; run-time n1 n2 -- | loop-sys )
   42:     POSTPONE 2dup POSTPONE < POSTPONE if
   43:     POSTPONE swap POSTPONE 1+ POSTPONE swap POSTPONE do ; immediate
   44: 
   45: : U-DO ( compilation -- -do-sys ; run-time u1 u2 -- | loop-sys )
   46:     POSTPONE 2dup POSTPONE u< POSTPONE if
   47:     POSTPONE swap POSTPONE 1+ POSTPONE swap POSTPONE do ; immediate

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