tests.scm

; guile -x ".sls" -x ".ss" -x ".guile.sls" tests.scm
(import (rnrs)
        (tagbody)
        (wak trc-testing))

(define-syntax inc!
  (syntax-rules ()
    ((inc! x)
     (set! x (+ x 1)))
    ((inc! x n)
     (set! x (+ x n)))))

(define-test-suite tagbody-tests
  "Suite of tests for the Scheme version of CL's TAGBODY")

(define-test-suite (clhs tagbody-tests)
  "Modified examples from the Common Lisp Hyperspec")

(define-test-case clhs basic-usage ()
  (test-eqv 15
            (let ((val #f))
              (tagbody
                (set! val 1)
                (go point-a)
                (inc! val 16)
               point-c
                (inc! val 4)
                (go point-b)
                (inc! val 32)
               point-a
                (inc! val 2)
                (go point-c)
                (inc! val 64)
               point-b
                (inc! val 8))
              val)))

(define-test-case clhs tags-have-dynamic-extent
  (letrec ((f1 (lambda (flag)
                 (let ((n 1))
                   (tagbody
                     (set! n (f2 flag (lambda () (go out))))
                    out
                     #f)
                   n)))
           (f2 (lambda (flag escape)
                 (if flag (escape) 2))))
    (test-case tags-have-dynamic-extent ()
      (test-eqv 2 (f1 #f))
      (test-eqv 1 (f1 #t)))))



(define-test-suite (mine tagbody-tests)
  "A few simple tests of my own")

(define-test-case mine fall-through
    ((description "If not occurrence of GO, all expressions are executed"))
  (test-eqv 3
            (let ((val 0))
              (tagbody
                (inc! val 1)
               tag
                (inc! val 2))             
              val)))

(define-test-case mine nested-tagbodies
    ((description "Inner TAGBODY forms should be able to GO to tags in an outer TAGBODY"))
  (test-eqv 55
            (let ((val 10)
                  (sum 0))
              (tagbody
               loop
                (tagbody
                 (if (zero? val)
                     (go done)
                     (begin
                       (inc! sum val)
                       (inc! val -1))))
                (go loop)
               done)
              sum)))


(run-test tagbody-tests)