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)))))

(defsuite
  "parameter-basic"
  (deftest
    "make-parameter creates parameter"
    (let ((p (make-parameter 42))) (assert (parameter? p))))
  (deftest
    "parameter returns default value"
    (let ((p (make-parameter 42))) (assert= 42 (p))))
  (deftest
    "parameter? false for non-parameters"
    (do
      (assert= false (parameter? 42))
      (assert= false (parameter? "hello"))
      (assert= false (parameter? (list 1 2)))))
  (deftest
    "two parameters are independent"
    (let
      ((p1 (make-parameter 10)) (p2 (make-parameter 20)))
      (do (assert= 10 (p1)) (assert= 20 (p2))))))

(defsuite
  "parameterize-basic"
  (deftest
    "parameterize rebinds single parameter"
    (let
      ((p (make-parameter 1)))
      (assert= 99 (parameterize ((p 99)) (p)))))
  (deftest
    "parameterize restores after body"
    (let
      ((p (make-parameter 1)))
      (do (parameterize ((p 99)) (p)) (assert= 1 (p)))))
  (deftest
    "parameterize with multiple bindings"
    (let
      ((p1 (make-parameter 10)) (p2 (make-parameter 20)))
      (parameterize
        ((p1 100) (p2 200))
        (do (assert= 100 (p1)) (assert= 200 (p2))))))
  (deftest
    "nested parameterize"
    (let
      ((p (make-parameter 1)))
      (parameterize
        ((p 10))
        (do
          (assert= 10 (p))
          (parameterize ((p 100)) (assert= 100 (p)))
          (assert= 10 (p))))))
  (deftest
    "parameterize with empty bindings"
    (assert= 42 (parameterize () 42)))
  (deftest
    "parameterize body returns last expr"
    (let
      ((p (make-parameter 0)))
      (assert= 3 (parameterize ((p 3)) 1 2 (p))))))

(defsuite
  "syntax-rules-basic"
  (deftest
    "simple constant pattern"
    (do
      (define-syntax my-const
        (syntax-rules ()
          ((_) 42)))
      (assert= 42 (my-const))))
  (deftest
    "pattern with variable"
    (do
      (define-syntax my-id
        (syntax-rules ()
          ((_ x) x)))
      (assert= 7 (my-id 7))))
  (deftest
    "variable in template expression"
    (do
      (define-syntax my-double
        (syntax-rules ()
          ((_ x) (+ x x))))
      (assert= 10 (my-double 5))))
  (deftest
    "multiple clauses by arity"
    (do
      (define-syntax my-if2
        (syntax-rules ()
          ((_ test then) (if test then nil))
          ((_ test then else-expr) (if test then else-expr))))
      (assert= 1 (my-if2 true 1))
      (assert= 2 (my-if2 false 1 2))))
  (deftest
    "ellipsis collects zero-or-more"
    (do
      (define-syntax my-list
        (syntax-rules ()
          ((_ x ...) (list x ...))))
      (assert= (list 1 2 3) (my-list 1 2 3))
      (assert= (list) (my-list))))
  (deftest
    "nested pattern"
    (do
      (define-syntax my-let1
        (syntax-rules ()
          ((_ ((var val)) body) (let ((var val)) body))))
      (assert= 10 (my-let1 ((x 10)) x))))
  (deftest
    "literal keyword matching"
    (do
      (define-syntax my-arrow
        (syntax-rules (=>)
          ((_ x => y) (list x y))))
      (assert= (list 1 2) (my-arrow 1 => 2))))
  (deftest
    "literal keyword no match falls through"
    (do
      (define-syntax my-cond
        (syntax-rules (=>)
          ((_ x => fn-expr) (fn-expr x))
          ((_ x y) (list x y))))
      (assert= (list 3 4) (my-cond 3 4))))
  (deftest
    "recursive macro with ellipsis"
    (do
      (define-syntax my-and
        (syntax-rules ()
          ((_) true)
          ((_ e) e)
          ((_ e1 e2 ...) (if e1 (my-and e2 ...) false))))
      (assert= true (my-and))
      (assert= 5 (my-and 5))
      (assert= true (my-and true true true))
      (assert= false (my-and true false true))))
  (deftest
    "swap macro"
    (do
      (define-syntax my-swap!
        (syntax-rules ()
          ((_ a b) (let ((tmp a)) (set! a b) (set! b tmp)))))
      (let ((x 1) (y 2))
        (my-swap! x y)
        (assert= 2 x)
        (assert= 1 y))))
  (deftest
    "when macro via syntax-rules"
    (do
      (define-syntax my-when
        (syntax-rules ()
          ((_ test body ...) (if test (do body ...) nil))))
      (assert= nil (my-when false 1 2 3))
      (assert= 3 (my-when true 1 2 3))))
  (deftest
    "nested ellipsis in binding pairs"
    (do
      (define-syntax my-let
        (syntax-rules ()
          ((_ ((var val) ...) body)
            (let ((var val) ...) body))))
      (assert= 6 (my-let ((a 1) (b 2) (c 3)) (+ a b c)))))
  (deftest
    "or macro with short-circuit"
    (do
      (define-syntax my-or
        (syntax-rules ()
          ((_) false)
          ((_ e) e)
          ((_ e1 e2 ...)
            (let ((t e1)) (if t t (my-or e2 ...))))))
      (assert= false (my-or))
      (assert= 42 (my-or 42))
      (assert= 1 (my-or 1 2 3))
      (assert= 3 (my-or false false 3))
      (assert= false (my-or false false false)))))

(defsuite
  "numeric-tower"
  (deftest
    "exact? recognizes integers"
    (do
      (assert (exact? 42))
      (assert (exact? 0))
      (assert (exact? -7))
      (assert (not (exact? 3.14)))
      (assert (not (exact? 0.5)))))
  (deftest
    "inexact? recognizes non-integers"
    (do
      (assert (inexact? 3.14))
      (assert (inexact? 0.5))
      (assert (not (inexact? 42)))
      (assert (not (inexact? 0)))))
  (deftest
    "exact->inexact identity for floats"
    (do
      (assert (number? (exact->inexact 42)))
      (assert= 42 (exact->inexact 42))
      (assert= 3.14 (exact->inexact 3.14))))
  (deftest
    "inexact->exact rounds to integer"
    (do
      (assert (integer? (inexact->exact 3.7)))
      (assert= 4 (inexact->exact 3.7))
      (assert= 3 (inexact->exact 3))
      (assert= -4 (inexact->exact -3.7))))
  (deftest
    "truncate toward zero"
    (do
      (assert= 3 (truncate 3.7))
      (assert= -3 (truncate -3.7))
      (assert= 3 (truncate 3.2))
      (assert= -3 (truncate -3.2))
      (assert= 5 (truncate 5))))
  (deftest
    "remainder sign follows dividend"
    (do
      (assert= 1 (remainder 7 3))
      (assert= -1 (remainder -7 3))
      (assert= 1 (remainder 7 -3))
      (assert= -1 (remainder -7 -3))))
  (deftest
    "modulo sign follows divisor"
    (do
      (assert= 1 (modulo 7 3))
      (assert= 2 (modulo -7 3))
      (assert= -2 (modulo 7 -3))
      (assert= -1 (modulo -7 -3))))
  (deftest
    "integer preservation through arithmetic"
    (do
      (assert (integer? (+ 3 4)))
      (assert (integer? (* 3 4)))
      (assert (integer? (- 10 3)))
      (assert (not (integer? (/ 7 2))))
      (assert (integer? (/ 6 3)))
      (assert (integer? (floor 3.7)))
      (assert (integer? (ceil 3.2)))
      (assert (integer? (round 3.5)))
      (assert (integer? (truncate 3.7))))))

(defsuite
  "vectors"
  (deftest
    "make-vector creates vector of given size"
    (let
      ((v (make-vector 5)))
      (do (assert (vector? v)) (assert= 5 (vector-length v)))))
  (deftest
    "make-vector with fill value"
    (let
      ((v (make-vector 3 42)))
      (do
        (assert= 42 (vector-ref v 0))
        (assert= 42 (vector-ref v 1))
        (assert= 42 (vector-ref v 2)))))
  (deftest
    "vector constructor from args"
    (let
      ((v (vector 1 2 3)))
      (do
        (assert= 3 (vector-length v))
        (assert= 1 (vector-ref v 0))
        (assert= 2 (vector-ref v 1))
        (assert= 3 (vector-ref v 2)))))
  (deftest
    "vector-set! mutates in place"
    (let
      ((v (make-vector 3 0)))
      (do
        (vector-set! v 1 99)
        (assert= 99 (vector-ref v 1))
        (assert= 0 (vector-ref v 0)))))
  (deftest
    "vector->list conversion"
    (assert= (list 1 2 3) (vector->list (vector 1 2 3))))
  (deftest
    "list->vector conversion"
    (let
      ((v (list->vector (list 10 20 30))))
      (do
        (assert (vector? v))
        (assert= 3 (vector-length v))
        (assert= 20 (vector-ref v 1)))))
  (deftest
    "vector-fill! sets all elements"
    (let
      ((v (vector 1 2 3)))
      (do
        (vector-fill! v 0)
        (assert= 0 (vector-ref v 0))
        (assert= 0 (vector-ref v 1))
        (assert= 0 (vector-ref v 2)))))
  (deftest
    "vector-copy creates independent copy"
    (let
      ((v1 (vector 1 2 3)))
      (let
        ((v2 (vector-copy v1)))
        (do
          (vector-set! v2 0 99)
          (assert= 1 (vector-ref v1 0))
          (assert= 99 (vector-ref v2 0))))))
  (deftest
    "vector? predicate"
    (do
      (assert (vector? (vector 1 2)))
      (assert (not (vector? (list 1 2))))
      (assert (not (vector? 42)))))
  (deftest
    "vector equality"
    (do
      (assert= (vector 1 2 3) (vector 1 2 3))
      (assert (not (= (vector 1 2) (vector 1 3)))))))

(defsuite
  "capabilities"
  (deftest
    "current-capabilities nil when unrestricted"
    (assert= nil (current-capabilities)))
  (deftest
    "has-capability? true when unrestricted"
    (assert (has-capability? "anything")))
  (deftest
    "with-capabilities sets capabilities"
    (with-capabilities
      (list "io-fetch" "io-query")
      (fn () (assert= (list "io-fetch" "io-query") (current-capabilities)))))
  (deftest
    "has-capability? checks active set"
    (with-capabilities
      (list "io-fetch")
      (fn
        ()
        (do
          (assert (has-capability? "io-fetch"))
          (assert (not (has-capability? "io-query")))))))
  (deftest
    "require-capability! passes when granted"
    (with-capabilities
      (list "io-fetch")
      (fn () (require-capability! "io-fetch"))))
  (deftest
    "require-capability! raises when missing"
    (with-capabilities
      (list "io-fetch")
      (fn () (assert (not (has-capability? "io-query"))))))
  (deftest
    "capabilities restore after body"
    (do
      (with-capabilities (list "io-fetch") (fn () nil))
      (assert= nil (current-capabilities))))
  (deftest
    "capabilities restore after nested call"
    (do
      (with-capabilities
        (list "io-fetch")
        (fn
          ()
          (with-capabilities
            (list "io-query")
            (fn () (assert (has-capability? "io-query"))))))
      (assert= nil (current-capabilities))))
  (deftest
    "nested capabilities narrow scope"
    (with-capabilities
      (list "io-fetch" "io-query")
      (fn
        ()
        (with-capabilities
          (list "io-fetch")
          (fn
            ()
            (do
              (assert (has-capability? "io-fetch"))
              (assert (not (has-capability? "io-query")))))))))
  (deftest
    "capability-restricted? predicate"
    (do
      (assert (not (capability-restricted?)))
      (with-capabilities
        (list "pure")
        (fn () (assert (capability-restricted?)))))))