(require (planet "78.ss" ("soegaard" "srfi.plt"))
         "../control.scm")

(check-reset!)

;;;
;;; WHILE
;;;

(check (let ((n 0) (m 0))
         (while (< n 5)
                (set! m (+ m n))
                (set! n (+ n 1)))
         (list (< n 5) m))
       => (list #f 10))

; check <test> is evaluated once only
; in each round.
(check (let ((n 0) (m 0))
         (while (begin 
                  (set! m (+ m 1))
                  (< n 5))
                (set! n (+ n 1)))
         m)
       => 6)

;;;
;;; UNTIL
;;;

(check (let ((n 5))
         (until (= n 0)
                (set! n (- n 1)))
         n)
       => 0)

(check (let ((n 5) (m 0))
         (until (begin 
                  (set! m (+ m 1))
                  (= n 0))
                (set! n (- n 1)))
         m)
       => 5)

;;;
;;; DOTIMES
;;;

; macro: (dotimes (var expr [finally]) body ...)
;   dotimes iterates over a series of integers.
;   dotimes evaluates expr and signals an error if the result
;   is not an integer. If expr is zero or negative, the
;   body is not executed. Otherwiese dotimes executed the body
;   for each integer from 0 up to but not including the value of expr.
;   During the evaluation of body, var is bound to each integer.
;   Then finally is evaluated if present, and the result is returned,
;   otherwise #void is returned. At the time finally is evaluated,
;   var is bound to the number of times body was excuted.

; check number of rounds
(check (let ((m 0))
         (dotimes (n 5)
                  (set! m (+ m 1)))
         m)
       => 5)
; check var is bound in body
(check (let ((xs '()))
         (dotimes (n 5)
                  (set! xs (cons n xs)))
         xs)
       => (list 4 3 2 1 0))
; check <expr> is evaluated once only
(check (let ((m 0) (k 0))
         (dotimes (n (begin (set! k (+ k 1)) 5))
                  (set! m (+ m 1)))
         k)
       => 1)
; check finally
(check (let ((m 0))
         (dotimes (n 5 7)
                  (set! m (+ m 1))))
       => 7)
; check that var is bound to number of rounds in finally
(check (let ((m 0))
         (dotimes (n 5 (set! m n)))
         m)
       => 5)
(check (let ((m 0))
         (dotimes (n 5 (set! m n))
                  (set! n 7))
         m)
       => 5)
; check finally is evaluated once only
(check (let ((m 0) (k 0))
         (dotimes (n 5 (begin (set! k (+ k 1)) 7))
                  (set! m (+ m 1)))
         k)
       => 1)
; check the body is not executed if the result of expr is non-positive
(check (let ((m 0)) 
         (dotimes (n 0)
                  (set! m (+ m 1)))
         m)
       => 0)
(check (let ((m 0)) 
         (dotimes (n -42)
                  (set! m (+ m 1)))
         m)
       => 0)
(check (let ((m 0)) 
         (dotimes (n -42 7)
                  (set! m (+ m 1))))
       => 7)
; check assignments to counter
(check (let ((m 0))
         (dotimes (n 10)
                  (set! m (+ m 1))
                  (set! n 6))
         m)
       => 10)

;;;
;;; TAGGED-BEGIN
;;;

; (go <tag>)
(check (let ([i 0])
         (tagged-begin
          loop (set! i (+ i 1))
               (if (< i 41) (go loop)))
         i)
       => 41)
; (return <expr>)
(check (let ([i 0])
         (tagged-begin
          loop (set! i (+ i 1))
               (if (< i 42) (go loop))
               (return i)))
       => 42)
; 2 tags, go and return
(check (let ([i 0])
         (tagged-begin
          loop (set! i (+ i 1))
               (go b)
          a    (if (< i 43) (go loop))
               (return i)
          b    (go a)))
       => 43)
; Example 4 ( <http://www.emacswiki.org/cgi-bin/wiki.pl?StateMachine> )
(check (let ((odd-numbers '()))
         (let ((a 0))
           (tagged-begin
            start
            (set! a 0)
            part-1
            (set! a (+ a 1))
            (set! odd-numbers (cons a odd-numbers))
            (cond
              ((>= a  9)  (go end))
              ((even? a)  (go part-1))
              (else       (go part-2)))
            part-2
            (set! a (+ a 1))
            (go part-1)
            end)
           odd-numbers))
       => (list 9 7 5 3 1))
  ; Example 5 ( Knuth: "The Art of Computer Programming", vol1, p.176)
  ; Inplace inversion of a permutation represented as a vector.
(check (let ()
         (define permutation (vector 'dummy 6 2 1 5 4 3))      ; (Knuth counts from 1 not 0 :-) )
         (define n           (- (vector-length permutation) 1))
         (define (X i)       (vector-ref permutation i))
         (define (X! i j)    (vector-set! permutation i j))
         
         (let ([m 0] [i 0] [j 0])
           (tagged-begin 
            I1   ; Initialize
            (set! m n)
            (set! j -1)
            I2   ; Next element
            (set! i (X m))
            (if (< i 0) (go I5))
            I3   ; Invert one
            (X! m j)
            (set! j (- m))
            (set! m i)
            (set! i (X m))
            I4   ; End of cycle?
            (if (> i 0) (go I3))
            (set! i j)
            I5   ; Store final value
            (X! m (- i))
            I6   ; Loop on m
            (set! m (- m 1))
            (if (> m 0) (go I2))))
         permutation)
       => (vector 'dummy 3 2 6 5 4 1))

; Example 6 (The CommonLisp Hyper Spec examples of tagbody)     
(check (let ()  
         (define val 'foo)
         (tagged-begin
                (set! val 1)
                (go a)
          c     (set! val (+ val 4))
                (go b)
                (set! val (+ val 32))
          a     (set! val (+ val 2))
                (go c)
                (set! val (+ val 64))
          b     (set! val (+ val 8)))
         val)
       => 15)

; Example 7
;   Demonstrates lexical scoping of tagged-begins,
;   and that an inner tagged-begin can use an outer tag.

(check (tagged-begin
        a (tagged-begin
           (go b))
        b (return 'hello-world))
       => 'hello-world)


; Demonstrates that tags are lexically shadowed.
(check (tagged-begin
        a (tagged-begin
           (go b)
           (return 'wrong)
           b (go c))
        b (return 'wrong)
        c (return 'correct))
       
       => 'correct)

;;;
;;; REPORT
;;;

(check-report)