File:  [gforth] / gforth / compat / loops.fs
Revision 1.3: download - view: text, annotated - select for diffs
Fri Jun 6 17:28:13 1997 UTC (22 years, 5 months ago) by anton
Branches: MAIN
CVS tags: v0-7-0, v0-6-2, v0-6-1, v0-6-0, v0-5-0, v0-4-0, HEAD
Environmental query "gforth" now returns the version-string
dictionary-end and unused moved into the kernel/basics.fs
Minor gforth.el bug fixes
Major rewrite of objects.fs (not yet done)
fixed -trailing bug (with test in test/other.fs)
optimization of fields with offset 0 in struct.fs and compat/struct.fs
other changes in compat/struct.fs (not yet done)
added ansreports to compat/*.fs
documentation changes
allot now checks for dict overflow
named [IS] (compilation semantics of IS).
minor changes

\ +DO, -DO...-LOOP and friends

\ This file is in the public domain. NO WARRANTY.

\ Hmm, this would be a good application for ]] ... [[

\ The program uses the following words
\ from CORE :
\ : POSTPONE over min ; immediate 2dup IF swap THEN drop negate +LOOP
\ ELSE 2drop < 1+ DO u<
\ from CORE-EXT :
\ ?DO u> 
\ from BLOCK-EXT :
\ \ 
\ from FILE :
\ ( 

: +DO ( compile-time: -- do-sys; run-time: n1 n2 -- )
    POSTPONE over POSTPONE min POSTPONE ?do ; immediate

: umin ( u1 u2 -- u )
    2dup u>
    IF
	swap
    THEN
    drop ;

: U+DO ( compile-time: -- do-sys; run-time: u1 u2 -- )
    POSTPONE over POSTPONE umin POSTPONE ?do ; immediate

\ -DO...-LOOP

\ You have to use the -LOOP implemented below with -DO or U-DO, you
\ cannot use it with ?DO

\ The implementation is a little more complicated. Basically, we
\ create an IF DO ... +LOOP THEN structure. The DO..+LOOP does not
\ exhibit the anomaly of ?DO...+LOOP; the IF..THEN is needed to
\ correct for DO's at-least-once semantics. The parameters are
\ conditioned a bit such that the result is as expected.

\ I define a '-do-sys' (whose implementation is 'orig do-sys'). Like
\ ANS Forth loop structures, this implementation of -DO..-LOOP
\ cannot be mixed with any other structures.

\ unlike Gforth's -LOOP, this implementation cannot handle all
\ unsigned increments, only positive integers
: -LOOP ( compilation -do-sys -- ; run-time loop-sys1 +n -- | loop-sys2 )
    POSTPONE negate POSTPONE +loop
    POSTPONE else POSTPONE 2drop POSTPONE then ; immediate

: -DO ( compilation -- -do-sys ; run-time n1 n2 -- | loop-sys )
    POSTPONE 2dup POSTPONE < POSTPONE if
    POSTPONE swap POSTPONE 1+ POSTPONE swap POSTPONE do ; immediate

: U-DO ( compilation -- -do-sys ; run-time u1 u2 -- | loop-sys )
    POSTPONE 2dup POSTPONE u< POSTPONE if
    POSTPONE swap POSTPONE 1+ POSTPONE swap POSTPONE do ; immediate

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