[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Testing the reference implementation



I'd like to run some tests with the reference implementation, which is written for Scheme 48, and unfortunately I don't have any experience with this system.

I've looked in the Scheme 48 docs and the web page for SRFI-34 and tried to get the following program to work. Unfortunately, in the "will" implementation it gives me only the following:

r6rs/will> (load "complex-test.scm")
complex-test.scm

Error: I'm bored.
       #{Inf}
       (&error)

Might someone help me with modifying this code so it will work?

Brad

;;; This program was written for Gambit-C. If you can find or write "with-exception-handler"
;;; for your scheme, it may work there, too.

;;; It was modified to work with the SRFI-77 reference implementation on Scheme 48, but I haven't
;;; had much luck getting it to run yet.

;;; This program tests +, -, *, and / with all combinations of "arguments" as the real part ;;; and the imaginary parts of the two arguments of the operators. It writes ths results ;;; to a file name "results" in a way that should be independent of how NaNs and infinities
;;; are represented on your scheme system.

;;; If you think the results should be significantly different for any of these operations,
;;; I'd like to hear about it: lucier at math dot purdue dot edu

(define plus-infinity (let loop ((x (r5rs->number 2.0)))
            (let ((two-x (* (r5rs->number 2.0) x)))
              (if (= x two-x)
                  x
                  (loop two-x)))))

(define minus-infinity (- plus-infinity))

(define plus-zero (/ (r5rs->number 1.0) plus-infinity))

(define minus-zero (/ (r5rs->number 1.0) minus-infinity))

(define not-a-number (/ plus-zero plus-zero))

(define arguments (list (r5rs->number 0)
            (r5rs->number 1)
            (r5rs->number -1)
            plus-zero
            minus-zero
            (r5rs->number 1.)
            (r5rs->number -1.)
            plus-infinity
            minus-infinity
            not-a-number))

(define operations+names (list (list + '+)
                   (list - '-)
                   (list * '*)
                   (list / '/)))

(define error-object (list "ERROR"))

(define (print-result name first-arg second-arg result)

  (define (print-arg arg)

    (define (print-number x)
      (cond ((exact? x)
         (if (>= x (r5rs->number 0))
         (display "+"))
         (display x))
        ((not (= x x)) (display "+NAN."))
        ((zero? x)
         (if (> (/ (r5rs->number 1.0) x) (r5rs->number 0.))
         (display "+0.")
         (display "-0.")))
        ((= (+ x x) x)
         (if (> x (r5rs->number 0.))
         (display "+INF.")
         (display "-INF.")))
        (else
         (if (>= x (r5rs->number 0.))
         (display "+"))
         (display x))))

    (if (eq? arg error-object)
    (display "ERROR")
    (begin
      (print-number (real-part arg))
      (print-number (imag-part arg))
      (display "i"))))

  (display "(")
  (display name)
  (display " ")
  (print-arg first-arg)
  (display " ")
  (print-arg second-arg)
  (display ")        =>         ")
  (print-arg result)
  (newline))

(with-output-to-file "results"
  (lambda ()
    (for-each (lambda (arg1)
        (for-each (lambda (arg2)
                (for-each (lambda (arg3)
                    (for-each (lambda (arg4)
                            (for-each (lambda (operation+name)
                                (let ((operation (car  operation+name))
                                      (name      (cadr operation+name))
(first-arg (make-rectangular arg1 arg2)) (second-arg (make-rectangular arg3 arg4)))
                                  (let ((result (with-exception-handler
                                         (lambda (args) error-object)
                                         (lambda ()
(operation first-arg second-arg))))) (print-result name first-arg second-arg result))))
                                  operations+names))
                          arguments))
                      arguments))
              arguments))
          arguments)))