Annotation of gforth/compat/loops.fs, revision 1.3
1.1 anton 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:
1.3 ! anton 7: \ The program uses the following words
! 8: \ from CORE :
! 9: \ : POSTPONE over min ; immediate 2dup IF swap THEN drop negate +LOOP
! 10: \ ELSE 2drop < 1+ DO u<
! 11: \ from CORE-EXT :
! 12: \ ?DO u>
! 13: \ from BLOCK-EXT :
! 14: \ \
! 15: \ from FILE :
! 16: \ (
! 17:
1.1 anton 18: : +DO ( compile-time: -- do-sys; run-time: n1 n2 -- )
19: POSTPONE over POSTPONE min POSTPONE ?do ; immediate
20:
21: : umin ( u1 u2 -- u )
22: 2dup u>
23: IF
24: swap
1.2 anton 25: THEN
1.1 anton 26: drop ;
27:
28: : U+DO ( compile-time: -- do-sys; run-time: u1 u2 -- )
29: POSTPONE over POSTPONE umin POSTPONE ?do ; immediate
30:
31: \ -DO...-LOOP
32:
33: \ You have to use the -LOOP implemented below with -DO or U-DO, you
34: \ cannot use it with ?DO
35:
36: \ The implementation is a little more complicated. Basically, we
37: \ create an IF DO ... +LOOP THEN structure. The DO..+LOOP does not
38: \ exhibit the anomaly of ?DO...+LOOP; the IF..THEN is needed to
39: \ correct for DO's at-least-once semantics. The parameters are
40: \ conditioned a bit such that the result is as expected.
41:
42: \ I define a '-do-sys' (whose implementation is 'orig do-sys'). Like
43: \ ANS Forth loop structures, this implementation of -DO..-LOOP
44: \ cannot be mixed with any other structures.
45:
46: \ unlike Gforth's -LOOP, this implementation cannot handle all
47: \ unsigned increments, only positive integers
48: : -LOOP ( compilation -do-sys -- ; run-time loop-sys1 +n -- | loop-sys2 )
49: POSTPONE negate POSTPONE +loop
50: POSTPONE else POSTPONE 2drop POSTPONE then ; immediate
51:
52: : -DO ( compilation -- -do-sys ; run-time n1 n2 -- | loop-sys )
53: POSTPONE 2dup POSTPONE < POSTPONE if
54: POSTPONE swap POSTPONE 1+ POSTPONE swap POSTPONE do ; immediate
55:
56: : U-DO ( compilation -- -do-sys ; run-time u1 u2 -- | loop-sys )
57: POSTPONE 2dup POSTPONE u< POSTPONE if
58: POSTPONE swap POSTPONE 1+ POSTPONE swap POSTPONE do ; immediate
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>