(module mathematica mzscheme
  
  (require "ml.ss"
           "translation.ss")
  
  (define current-mathlink
    (make-parameter #f
                    (lambda (lp)
                      (unless (or (not lp)
                                  (MathLink? lp))
                        (raise-type-error 'current-mathlink "MathLink/#f" lp))
                      lp)))
  
  (define (MathPutSymbol sym lp)
    (MathPutNext 35 lp)
    (MathPutString (symbol->string sym) lp))
  
  (define (MathPut exp lp)
    (cond ((boolean? exp)
           (MathPutSymbol (if exp 'True 'False) lp))
          ((and (number? exp)
                (not (or (eq? exp +inf.0)
                         (eq? exp -inf.0)
                         (eq? exp +nan.0))))
           (MathPutNumber exp lp))
          ((symbol? exp)
           (MathPutSymbol exp lp))
          ((string? exp)
           (MathPutString exp lp))
          ((void? exp)
           (MathPutSymbol 'Null lp))
          ((and (list? exp)
                (not (null? exp)))
           (let ((mexp (Scheme->Mathematica exp)))
             (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 (MathPutInteger num lp)
    (MathPutNext 43 lp)
    (MathPutString (number->string num) lp))
  
  (define (MathPutNumber num lp)
    (cond ((and (integer? num)
                (exact? num))
           (MathPutInteger num lp))
          ((and (rational? num)
                (exact? num))
           (MathPutFunction 'Rational 2 lp)
           (MathPutInteger (numerator num) lp)
           (MathPutInteger (denominator num) lp))
          ((real? num)
           (MathPutNext 42 lp)
           (MathPutString (number->string num) lp))
          (else ;(complex? num)
           (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)
             (MathGetString lp))
            ((= pac 2)
             (display (MathGetString lp))
             (MathNewPacket lp)
             (MathGet lp))
            ((= pac 5)
             (MathNewPacket lp)
             (MathNextPacket lp)
             (warning (MathGetString lp))
             (MathNewPacket lp)
             (MathGet lp))
            ((= pac 0)
             (error "Mathematica Kernel Fatal Error"))
            (else
             (MathNewPacket lp)
             (MathGet lp)))))
  
  (define (MathGetExp lp)
    (let ((next (MathGetNext lp)))
      (cond ((= next 35)
             (let ((sym (string->symbol (MathGetString lp))))
               (cond
                 ((eq? sym 'True) #t)
                 ((eq? sym 'False) #f)
                 ((eq? sym 'Null) (void))
                 (else sym))))
            ((= next 34)
             (MathGetString lp))
            ((= next 43)
             (string->number (MathGetString lp)))
            ((= next 42)
             (exact->inexact (string->number (MathGetString lp))))
            ((= next 70)
             (Mathematica->Scheme
              (let* ((n (MathGetArgCount lp))
                     (head (list (MathGetExp lp))))
                (let loop ((i n) (p head))
                  (if (zero? i)
                      head
                      (begin
                        (set-cdr! p (list (MathGetExp lp)))
                        (loop (sub1 i) (cdr p)))))))))))
  
  (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)))
         (current-mathlink lp)
         lp))))
  
  (define MathEval
    (let ((MathEval-checked
           (lambda (exp lp)
             (MathPutFunction 'EvaluatePacket 1 lp)
             (MathPut exp lp)
             (MathEndPacket lp)
             (MathGet lp))))
      (case-lambda
        ((exp)
         (unless (current-mathlink)
           (MathKernel))
         (MathEval-checked exp (current-mathlink)))
        ((exp lp)
         (unless (MathLink? lp)
           (raise-type-error 'MathEval "MathLink" lp))
         (MathEval-checked exp lp)))))
  
  (define MathExit
    (let ((me (lambda (lp)
                (MathPutFunction 'Exit 0 lp)
                (MathEndPacket lp)
                (MathNextPacket lp)
                (MathClose lp))))
      (case-lambda
        (()
         (unless (current-mathlink)
           (error "No current MathLink"))
         (me (current-mathlink))
         (current-mathlink #f))
        ((lp)
         (unless (MathLink? lp)
           (raise-type-error 'MathExit "MathLink" lp))
         (when (eq? lp (current-mathlink))
           (current-mathlink #f))
         (me lp)))))
  
  (provide MathKernel
           MathEval
           MathExit
           MathLink?
           current-mathlink))