mma.ss
(module mma mzscheme
  
  (require "ml.ss"
           "translation.ss"
           (lib "etc.ss")
           (lib "contract.ss"))
  
  (define-struct MathLink (ml ref))
  
  (define Eval/c
    (opt->* ((flat-rec-contract Mexp
                                number? boolean? symbol? string? void?
                                (cons/c Mexp (listof Mexp))))
            (MathLink?) any))
  
  (provide/contract (MathKernel
                     (->* () (listof bytes?) (MathLink?)))
                    (MathEval Eval/c)
                    (MathExit
                     (opt-> () (MathLink?) void?))
                    (current-mathlink
                     (parameter/c (or/c false/c MathLink?))))
  (provide MathLink?)
  
  (define current-mathlink
    (make-parameter #f))
  
  (define flush-input
    (let ([buf (make-bytes 16)])
      (lambda ()
        (do ()
          ((zero? (read-bytes-avail!* buf)))))))
  
  (define (MathPutSymbol sym lp)
    (let* ((str (symbol->string sym))
           (lst (string->list str)))
      (if (and (not (null? lst))
               (or (char-alphabetic? (car lst))
                   (char=? (car lst) #\$))
               (andmap (lambda (c)
                         (or (char-alphabetic? c)
                             (char-numeric? c)))
                       (cdr lst)))
          (MathPutNext 35 lp)
          (MathPutFunction 'Symbol 1 lp))
      (MathPutString str lp)))
  
  (define (MathGetNumber lp)
    (string->number (bytes->string/latin-1 (MathGetByteString lp))))
  
  (define (MathPut exp lp)
    (cond ((boolean? exp)
           (MathPutCharSymbol (if exp 'True 'False) lp))
          ((number? exp)
           (MathPutNumber exp lp))
          ((symbol? exp)
           (MathPutSymbol exp lp))
          ((string? exp)
           (MathPutString exp lp))
          ((void? exp)
           (MathPutCharSymbol 'Null lp))
          (else
           (let ((mexp (Scheme->Mathematica exp)))
             (MathPutNext 70 lp)
             (MathPutArgCount (sub1 (length mexp)) lp)
             (andmap (lambda (arg) (MathPut arg lp)) mexp)))))
  
  (define (MathGet lp)
    (MathWait lp)
    (parameterize-break
     #f
     (case (MathNextPacket lp)
       ((0)
        (unless (MathClearError lp)
          (error "MathLink fatal error"))
        (MathNewPacket lp)
        (MathGet lp))
       ((1)
        (display (MathGetString lp))
        (flush-input)
        (MathPutFunction 'EnterExpressionPacket 1 lp)
        (MathPut (read) lp)
        (MathNewPacket lp)
        (MathGet lp))
       ((2)
        (display (MathGetString lp))
        (MathNewPacket lp)
        (MathGet lp))
       ((3)
        (MathGetExp lp))
       ((4)
        (MathGetString lp))
       ((5)
        (MathNewPacket lp)
        (MathNextPacket lp)
        (warning (MathGetString lp))
        (MathNewPacket lp)
        (MathGet lp))
       ((21)
        (display (MathGetString lp))
        (flush-input)
        (MathPutFunction 'TextPacket 1 lp)
        (MathPutString (read-line (current-input-port) 'any) lp)
        (MathNewPacket lp)
        (MathGet lp))
       (else
        (MathNewPacket lp)
        (MathGet lp)))))
  
  (define (MathGetExp lp)
    (case (MathGetNext lp)
      ((35)
       (let ((sym (MathGetSymbol lp)))
         (case sym
           ((True) #t)
           ((False) #f)
           ((Null) (void))
           ((Indeterminate) +nan.0)
           (else sym))))
      ((34)
       (MathGetString lp))
      ((43)
       (MathGetNumber lp))
      ((42)
       (let ((t (MathGetNumber lp)))
         (when (= (abs t) +inf.0)
           (warning "MathLink: Mathematica returns a real number that doesn't fit in a C double."))
         t))
      ((70)
       (Mathematica->Scheme
        (let* ((n (MathGetArgCount lp))
               (head (list (MathGetExp lp))))
          (do ((i n (sub1 i))
               (p head (cdr p)))
            ((zero? i) head)
            (set-cdr! p (list (MathGetExp lp)))))))))
  
  (define MathKernel
    (case-lambda
      (()
       (if (eq? (system-type 'os) 'unix)
           (MathKernel #"-linkname" #"math -mathlink")
           ;(MathKernel #"-linkmode" #"launch")
           (MathKernel #"-linkname" #"MathKernel -mathlink")))
      (arg
       (let* ((raw-ml (apply init_and_openlink arg))
              (lp (make-MathLink (car raw-ml) (cdr raw-ml))))
         (current-mathlink lp)
         lp))))
  
  (define MathEval
    (opt-lambda (exp (lp (or (current-mathlink) (MathKernel))))
      (let ((ml (MathLink-ml lp)))
        (parameterize-break
         #f
         (MathPutFunction 'EvaluatePacket 1 ml)
         (MathPut exp ml)
         (MathEndPacket ml))
        (MathGet ml))))
  
  (define (MathWait lp)
    (with-handlers ((exn:break?
                     (lambda (x)
                       (MathPutMessage 3 lp))))
      (do ()
        ((MathReady lp))
        (sleep)))
    (unless (zero? (MathError lp))
      (error (string-append "MathLink Error: "
                            (bytes->string/latin-1 (MathErrorMessage lp))))))
  
  (define MathExit
    (case-lambda
      (()
       (cond ((current-mathlink)
              => MathExit)
             (else
              (error 'MathExit "No current MathLink"))))
      ((lp)
       (if (eq? lp (current-mathlink))
           (current-mathlink #f))
       (let ((ml (MathLink-ml lp)))
         (MathPutMessage 1 ml)
         (MathClose ml (MathLink-ref lp)))))))