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

Testing the reference implementation

This page is part of the web mail archives of SRFI 77 from before July 7th, 2015. The new archives for SRFI 77 contain all messages, not just those from before July 7th, 2015.



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