cyclone/tests/base.scm
yorickhardy 2b0f0601a6
Raise errors and objects with different tags (#557)
* tests/base.scm: add two tests for issue #556

The two tests are adapted from issue #556 (originally from r7rs).
The tests currently fail because errors and raised objects are
treated in the same way.

* Use different tags for raised objects and raised errors

The behaviour for raising an error (error message irritants) and
objects (raise object) are different in r7rs. So tag error objects
differently, and adjust the raised object handling to handle
the raised object instead of a list containing the raised object.

This should resolve issue #556.

* runtime: use the correct string length for comparison

Fix for the pull request adressing issue #556.

* runtime: distinguish exceptions and errors in default handler

* repl: use error-object? to decide whether an error or an exception was raised

This makes error messages a bit more informative.  Also, if error objects become
a distinct type, then the repl implementation will continue to be correct. The
(deleted) second cond clause seemed to be bit redundant - I am not sure what the
original intent was.

* tests/base.scm: revert accidental deletion of else clause

* Display exceptions as errors for consistency
2025-02-23 16:23:16 -05:00

217 lines
5 KiB
Scheme

;;;; Cyclone Scheme
;;;; https://github.com/justinethier/cyclone
;;;;
;;;; Copyright (c) 2014-2021, Justin Ethier
;;;; All rights reserved.
;;;;
;;;; This module contains unit tests for threading / SRFI 18.
;;;;
(import
(scheme base)
(scheme eval)
(scheme inexact)
(scheme write)
(cyclone test))
(define vec #(1 2))
(test-group
"vector literals"
(test #(1 2) vec)
(test vec (vector 1 2))
)
(test-group
"strings"
(test "??>" "??>")
)
(test-group
"make-list"
(test '() (make-list -2))
)
(test-group
"apply"
(test '(5 1 2) (eval '(apply cons '(5 (1 2)))))
(test '(5 1 2) (apply cons '(5 (1 2))))
)
(cond-expand
(memory streams
(test-group
"I/O"
(define p (open-input-string "one\ntwo\n"))
(test #\o (read-char p))
(test "ne" (read-line p))
(test "two" (read-line p))
(test (eof-object) (read-line p))
(define p (open-input-string "one\ntwo\n"))
(test "one" (read-line p))
(test #\t (read-char p))
(test #\w (read-char p))
(test "o" (read-line p))
)
)
(else #f)
)
(test-group
"rationals"
(test 3.0 (numerator (/ 6 4)))
(test 2.0 (denominator (/ 6 4)))
(test 3.0 (expt 81 1/4))
(test #t
(< 1.0e+40
(/ 33333333333333333333333333333333333333333 3.0)
1.2e+40))
)
(test-group
"numeric operations - floor, truncate, "
(test -1 (truncate -1))
(test -1.0 (truncate -1.0))
(test -1.0 (truncate -1.1))
(test -1.0 (truncate -1.1))
(test +inf.0 (truncate +inf.0))
(test (values 2 1) (floor/ 5 2))
(test (values -3 1) (floor/ -5 2))
(test (values -3 -1) (floor/ 5 -2))
(test (values 2 -1) (floor/ -5 -2))
(test (values 2 1) (truncate/ 5 2))
(test (values -2 -1) (truncate/ -5 2))
(test (values -2 1) (truncate/ 5 -2))
(test (values 2 -1) (truncate/ -5 -2))
(test (values 2.0 -1.0) (truncate/ -5.0 -2))
(test 4 (gcd 32 -36))
(test 0 (gcd))
(test 288 (lcm 32 -36))
(test 288.0 (lcm 32.0 -36))
(test 1 (lcm))
(test -5.0 (floor -4.3))
(test -4.0 (ceiling -4.3))
(test -4.0 (truncate -4.3))
(test -4.0 (round -4.3))
(test 3.0 (floor 3.5))
(test 4.0 (ceiling 3.5))
(test 3.0 (truncate 3.5))
(test 4.0 (round 3.5))
(test 2.0 (round 2.5))
(test -4.0 (round -3.5))
(test -2.0 (round -2.5))
(test 4.0 (round 7/2)) ;; Rationals not supported, so result is inexact
(test 7 (round 7))
(test 3.0 (numerator (/ 6 4))) ;; Inexact because we don't support rationals yet
(test 2.0 (denominator (/ 6 4))) ;; Inexact because we don't support rationals yet
(test 2.0 (denominator (inexact (/ 6 4))))
)
(test-group
"sqrt"
(test 1i (sqrt -1))
(test 1i (sqrt -1.0))
(test +i (sqrt -1.0))
(test 2 (sqrt 4))
(test 2.0 (sqrt 4.0))
(test 2i (sqrt -4.0))
(test #t (complex? (sqrt -1)))
(test #t (complex? (sqrt -i)))
)
(test-group
"exact"
(test -1 (exact -1))
(test -1 (exact -1.0))
(test -1 (exact -1.1))
(test -1 (exact -1.1))
(test 1.0+1.0i (exact 1.1+1.2i))
;(test #t (bignum? (exact 111111111111111111111111111.0)))
;(test #t (bignum? (exact -111111111111111111111111111.0)))
;(test +inf.0 (exact +inf.0))
)
(test-group
"records"
(define-record-type employee
(make-employee name title)
employee?
(name get-name)
(title get-title)
(test get-test set-test!)) ;; Uninitialized by constructor
(define e (make-employee "test-name" "job 1"))
(test #f (get-test e))
(set-test! e 'test-field)
(test 'test-field (get-test e))
)
(test-group
"assoc"
(define a 0.0)
(test '(0.0) (assoc a (list (list a))))
(test '(0.0) (assoc 0.0 (list (list a))))
(test '(0.0) (assv a (list (list a))))
(test '(0.0) (assv 0.0 (list (list a))))
(test '(0.0) (assq a (list (list a))))
(test #f (assq 0.0 (list (list a))))
)
(test-group
"member"
(define m 0.0)
(test '(0.0) (member m (list m)))
(test '(0.0) (member 0.0 (list m)))
(test '(0.0) (memv m (list m)))
(test '(0.0) (memv 0.0 (list m)))
(test '(0.0) (memq m (list m)))
(test #f (memq 0.0 (list m)))
)
(test-group
"exception handling"
(define (capture-output thunk)
(let ((output-string (open-output-string)))
(parameterize ((current-output-port output-string))
(thunk))
(let ((result (get-output-string output-string)))
(close-output-port output-string)
result)))
(test
"should be a number65"
(capture-output
(lambda ()
(with-exception-handler
(lambda (con)
(cond
((string? con)
(display con))
(else
(display "a warning has been issued")))
42)
(lambda ()
(display
(+ (raise-continuable "should be a number")
23)))))))
(test
"condition: an-error"
(capture-output
(lambda ()
(call-with-current-continuation
(lambda (k)
(with-exception-handler
(lambda (x)
(display "condition: ")
(write x)
(k "exception"))
(lambda ()
(+ 1 (raise 'an-error)))))))))
)
(test-exit)