(module mathematica mzscheme
  
  (require "ml.ss"
           "translation.ss")
  
  (define mathlink '(living-links))
  
  (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))
          ((number? exp)
           (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)))
         (set-cdr! mathlink (cons lp (cdr mathlink)))
         lp))))
  
  (define MathEval
    (let ((MathEval-checked
           (lambda (exp lp)
             (MathPutFunction 'EvaluatePacket 1 lp)
             (MathPut exp lp)
             (MathEndPacket lp)
             (with-handlers ((exn:break?
                              (lambda (x) (MathPutMessage 3 lp))))
               (let loop ()
                 (unless (MathReady lp)
                   (sleep)
                   (loop))))
             (MathGet lp))))
      (case-lambda
        ((exp)
         (when (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)
                (MathPutFunction 'Exit 0 lp)
                (MathEndPacket lp)
                (MathNextPacket lp)
                (MathClose lp))))
      (case-lambda
        (()
         (if (null? (cdr mathlink))
             (error "No living MathLink"))
         (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?))