(module mathematica mzscheme
  
  (require "ml.ss"
           "translation.ss")
  
  (define mathlink '(living-links))
  
  (define-struct (exn:mathematica exn) ())
  
  (define (MathGetSymbol/Boolean/Void lp)
    (let ((sym (MathGetSymbol lp)))
      (cond
        ((eq? sym 'True) #t)
        ((eq? sym 'False) #f)
        ((eq? sym 'Null) (void))
        (else sym))))
  
  (define (MathPut exp lp)
    (cond ((boolean? exp)
           (MathPutSymbol (if exp 'True 'False) lp))
          ((number? exp)
           (MathPutNumber exp lp))
          ((symbol? exp)
           (MathPutSymbol exp lp))
          ((string? exp)
           (MathPutUnicodeString exp lp))
          ((void? exp)
           (MathPutSymbol 'Null lp))
          ((and (list? exp)
                (not (null? exp)))
           (let ((mexp (Scheme->Mathematica exp)))
             (and (MathPutNext 70 lp)
                  (MathPutArgCount (sub1 (length mexp)) lp)
                  (andmap (lambda (arg) (MathPut arg lp))
                          mexp))))
          (else
           (MathEndPacket lp)
           (raise-type-error 'MathEval
                             "number/boolean/symbol/string/void/list"
                             exp))))
  
  (define (MathPutNumber num lp)
    (cond ((and (integer? num)
                (exact? num))
           (and (MathPutNext 43 lp)
                (MathPutByteString (string->bytes/utf-8 (number->string num)) lp)))
          ((and (rational? num)
                (exact? num))
           (and (MathPutFunction 'Rational 2 lp)
                (MathPutNumber (numerator num) lp)
                (MathPutNumber (denominator num) lp)))
          ((real? num)
           (and (MathPutNext 42 lp)
                (MathPutByteString (string->bytes/utf-8 (number->string num)) lp)))
          (else ;(complex? num)
           (and (MathPutFunction 'Complex 2 lp)
                (MathPutNumber (real-part num) lp)
                (MathPutNumber (imag-part num) lp)))))
  
  (define (MathGet lp)
    (let ((pac (MathNextPacket lp)))
      (cond ((= pac 3)
             (MathGetExp lp))
            ((= pac 4)
             (MathGetUnicodeString lp))
            ((= pac 2)
             (display (MathGetUnicodeString lp))
             (and (MathNewPacket lp)
                  (MathGet lp)))
            ((= pac 5)
             (and (MathNewPacket lp)
                  (MathNextPacket lp)
                  (warning (MathGetByteString lp))
                  (MathNewPacket lp)
                  (MathGet lp)))
            ((= pac 0)
             (raise
              (make-exn:mathematica "Mathematica Kernel Fatal Error"
                                    (current-continuation-marks))))
            (else
             (and (MathNewPacket lp)
                  (MathGet lp))))))
  
  (define (MathGetExp lp)
    (let ((next (MathGetNext lp)))
      (cond ((= next 35)
             (MathGetSymbol/Boolean/Void lp))
            ((= next 34)
             (MathGetUnicodeString lp))
            ((= next 43)
             (string->number (bytes->string/utf-8 (MathGetByteString lp))))
            ((= next 42)
             (exact->inexact (string->number (bytes->string/utf-8 (MathGetByteString lp)))))
            ((= next 70)
             (MathGetFunction lp))
            (else
             (raise
              (make-exn:mathematica "Unknown return expression type"
                                    (current-continuation-marks)))))))
  
  (define MathGetFunction
    (letrec ((build-list
              (lambda (n f)
                (if (zero? n)
                    '()
                    (cons (f) (build-list (sub1 n) f))))))
      (lambda (lp)
        (Mathematica->Scheme
         (build-list (add1 (MathGetArgCount lp))
                     (lambda () (MathGetExp lp)))))))
  
  (define MathKernel
    (case-lambda
      (()
       (MathKernel #"-linkname" #"math -mathlink"))
      (arg
       (unless (andmap bytes? arg)
         (raise-type-error 'MathKernel "byte strings" arg))
       (let ((lp (apply init_and_openlink arg)))
         (set-cdr! mathlink (cons lp (cdr mathlink)))
         lp))))
  
  (define MathEval
    (let ((MathEval-checked
           (lambda (exp lp)
             (unless (and (MathPutFunction 'EvaluatePacket 1 lp)
                          (MathPut exp lp)
                          (MathEndPacket lp))
               (raise
                (make-exn:mathematica "Mathematica Link Error"
                                      (current-continuation-marks))))
             (with-handlers ((exn:break?
                              (lambda (x) (MathPutMessage 3 lp))))
               (let loop ()
                 (sleep)
                 (if (MathReady lp)
                     (MathGet lp)
                     (loop)))))))
      (case-lambda
        ((exp)
         (if (null? (cdr mathlink))
             (MathKernel))
         (MathEval-checked exp (cadr mathlink)))
        ((exp lp)
         (unless (living-MathLink? lp)
           (raise-type-error 'MathEval "living MathLink" lp))
         (MathEval-checked exp lp)))))
  
  (define MathExit
    (let ((me (lambda (lp)
                (and (MathPutFunction 'Exit 0 lp)
                     (MathEndPacket lp)
                     (MathNextPacket lp)
                     (MathClose lp)))))
      (case-lambda
        (()
         (if (null? (cdr mathlink))
             (raise
              (make-exn:mathematica "No living MathLink"
                                    (current-continuation-marks))))
         (me (cadr mathlink))
         (set-cdr! mathlink (cddr mathlink)))
        ((lp)
         (unless (MathLink? lp)
           (raise-type-error 'MathExit "MathLink" lp))
         (let loop ((alst mathlink))
           (cond ((null? (cdr alst))
                  (raise-type-error 'MathExit "living MathLink" lp))
                 ((eq? lp (cadr alst))
                  (set-cdr! alst (cddr alst)))
                 (else
                  (loop (cdr alst)))))
         (me lp)))))
  
  (define (living-MathLink? lp)
    (and (MathLink? lp)
         (memq lp (cdr mathlink))))
  
  (provide MathKernel
           MathEval
           MathExit
           MathLink?
           living-MathLink?
           (struct exn:mathematica ())))