rose-ash/spec/tests/test-r7rs.sx

(defsuite
  "callcc-basic"
  (deftest "simple escape" (assert= (call/cc (fn (k) (k 42))) 42))
  (deftest "normal return (k unused)" (assert= (call/cc (fn (k) 99)) 99))
  (deftest
    "escape from nested expression"
    (assert= (+ 1 (call/cc (fn (k) (+ 10 (k 42))))) 43))
  (deftest
    "call-with-current-continuation alias"
    (assert= (call-with-current-continuation (fn (k) (k 77))) 77))
  (deftest
    "call/cc in let binding"
    (assert= (let ((x (call/cc (fn (k) (k 5))))) (+ x 10)) 15))
  (deftest
    "call/cc in tail position"
    (assert= (if true (call/cc (fn (k) (k 1))) 2) 1))
  (deftest
    "call/cc with no args to k"
    (assert= (call/cc (fn (k) (k))) nil)))

(defsuite
  "raise-basic"
  (deftest
    "raise with handler-bind"
    (assert=
      (handler-bind
        (((fn (c) true) (fn (c) c)))
        (+ 1 (raise-continuable 42)))
      43))
  (deftest
    "raise-continuable returns to call site"
    (assert=
      (handler-bind
        (((fn (c) true) (fn (c) (+ c 100))))
        (+ 1 (raise-continuable 42)))
      143))
  (deftest
    "raise non-continuable errors on handler return"
    (assert=
      (try-catch
        (fn () (handler-bind (((fn (c) true) (fn (c) c))) (raise 42)))
        (fn (e) "caught"))
      "caught"))
  (deftest
    "unhandled raise gives host error"
    (assert=
      (try-catch (fn () (raise 99)) (fn (e) "unhandled"))
      "unhandled")))

(defsuite
  "guard-basic"
  (deftest
    "guard catches with matching clause"
    (assert= (guard (exn ((number? exn) (+ exn 1))) (raise 41)) 42))
  (deftest
    "guard with else clause"
    (assert= (guard (exn (else "caught")) (raise "boom")) "caught"))
  (deftest
    "guard passes through on no exception"
    (assert= (guard (exn (else "caught")) (+ 1 2)) 3))
  (deftest
    "guard re-raises when no clause matches"
    (assert=
      (try-catch
        (fn
          ()
          (guard (exn ((number? exn) "number")) (raise "string-value")))
        (fn (e) "re-raised"))
      "re-raised"))
  (deftest
    "nested guard"
    (assert=
      (guard
        (outer (else (str "outer: " (error-message outer))))
        (guard (inner ((number? inner) (+ inner 1))) (raise 41)))
      42)))

(defsuite
  "with-exception-handler"
  (deftest
    "basic catch with continuable"
    (assert=
      (with-exception-handler
        (fn (c) (+ c 100))
        (fn () (+ 1 (raise-continuable 42))))
      143)))

(defsuite
  "error-objects"
  (deftest
    "make-error-object creates dict"
    (assert (error-object? (make-error-object "test" (list)))))
  (deftest
    "error-message accessor"
    (assert= (error-message (make-error-object "hello" (list))) "hello"))
  (deftest
    "error-object-irritants accessor"
    (assert=
      (error-object-irritants (make-error-object "msg" (list 1 2 3)))
      (list 1 2 3)))
  (deftest
    "raise error object caught by guard"
    (assert=
      (guard
        (exn ((error-object? exn) (error-message exn)))
        (raise (make-error-object "test error" (list 1 2))))
      "test error")))

(defsuite
  "multi-map"
  (deftest
    "map over two lists"
    (assert= (map + (list 1 2 3) (list 10 20 30)) (list 11 22 33)))
  (deftest
    "map over three lists"
    (assert=
      (map + (list 1 2) (list 10 20) (list 100 200))
      (list 111 222)))
  (deftest
    "stops at shortest list"
    (assert= (map + (list 1 2 3) (list 10 20)) (list 11 22)))
  (deftest
    "empty list returns empty"
    (assert= (map + (list) (list 1 2)) (list)))
  (deftest
    "single list backwards compat"
    (assert= (map (fn (x) (* x 2)) (list 1 2 3)) (list 2 4 6)))
  (deftest
    "map list constructor over two lists"
    (assert=
      (map (fn (a b) (list a b)) (list 1 2) (list 3 4))
      (list (list 1 3) (list 2 4)))))

(defsuite
  "cond-arrow"
  (deftest
    "basic arrow clause"
    (assert= (cond (1 => (fn (x) (+ x 10)))) 11))
  (deftest "arrow with identity" (assert= (cond (42 => (fn (x) x))) 42))
  (deftest
    "false clause skipped, else taken"
    (assert= (cond (false => (fn (x) x)) (else 99)) 99))
  (deftest
    "arrow with complex expression"
    (assert= (cond (42 => (fn (x) (* x 2)))) 84)))

(defsuite
  "do-iteration"
  (deftest "basic count" (assert= (do ((i 0 (+ i 1))) ((= i 5) i)) 5))
  (deftest
    "accumulator"
    (assert= (do ((i 0 (+ i 1)) (sum 0 (+ sum i))) ((= i 4) sum)) 6))
  (deftest
    "collect into list"
    (assert=
      (do ((v (list) (append v (list i))) (i 0 (+ i 1))) ((= i 3) v))
      (list 0 1 2)))
  (deftest
    "do as begin still works"
    (assert= (let ((x 0)) (do (set! x 42)) x) 42)))

(defsuite
  "r7rs-aliases"
  (deftest
    "car/cdr"
    (assert= (car (list 1 2 3)) 1)
    (assert= (cdr (list 1 2 3)) (list 2 3)))
  (deftest "cadr" (assert= (cadr (list 1 2 3)) 2))
  (deftest
    "null?"
    (assert (null? nil))
    (assert (null? (list)))
    (assert (not (null? (list 1)))))
  (deftest
    "pair?"
    (assert (pair? (list 1)))
    (assert (not (pair? (list))))
    (assert (not (pair? 42))))
  (deftest
    "procedure?"
    (assert (procedure? (fn () 1)))
    (assert (procedure? +))
    (assert (not (procedure? 42))))
  (deftest
    "integer?"
    (assert (integer? 42))
    (assert (integer? 0))
    (assert (not (integer? 3.14)))
    (assert (not (integer? "hello"))))
  (deftest
    "symbol->string"
    (assert= (symbol->string (quote hello)) "hello"))
  (deftest "number->string" (assert= (number->string 42) "42"))
  (deftest
    "boolean=?"
    (assert (boolean=? true true))
    (assert (boolean=? false false))
    (assert (not (boolean=? true false)))))