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