add phantom

mrmathematica · Sep 16, 2013 · 5def24e · 5def24e
1 parent 1ae9c28
commit 5def24e
Show file tree

Hide file tree

Showing 2 changed files with 38 additions and 42 deletions.
diff --git a/light.ss b/light.ss
@@ -166,9 +166,7 @@
     (arg
      (let ((link (apply MLOpen arg)))
        (set-MathLink-ref! link
-                          (register-custodian-shutdown link MLClose
-                                                       #:at-exit? #t
-                                                       #:weak? #t))
+                          (register-custodian-shutdown link MLClose #:at-exit? #t))
        (register-finalizer link MathExit)
        (current-mathlink link)
        link))))
@@ -197,4 +195,5 @@
                               (when ref
                                 (set-MathLink-ref! link #f)
                                 (unregister-custodian-shutdown link ref)
-                                (MLClose link))))))))
+                                (MLClose link)
+                                (set-phantom-bytes! (MathLink-phantom link) 0))))))))
diff --git a/mathlink.ss b/mathlink.ss
@@ -5,10 +5,10 @@
 (provide (except-out (all-defined-out)
                      mathlink))
 
-(define-struct MathLink (ep lp (ref #:mutable) sema))
+(define-struct MathLink (ep lp (ref #:mutable) sema phantom))
 
 (define warning
-  (get-ffi-obj "scheme_warning" #f
+  (get-ffi-obj 'scheme_warning #f
                (_fun (_bytes = #"%T") _scheme -> _void)))
 
 (define-struct (exn:fail:mathlink exn:fail) () #:transparent)
@@ -30,10 +30,10 @@
 
 (define MLOpen
   (let ((MLInitialize
-         (get-ffi-obj "MLInitialize" mathlink
+         (get-ffi-obj 'MLInitialize mathlink
                       (_fun (_pointer = #f) -> (p : _pointer)
                             -> (or p (mathlink-error "MathKernel: MathLink Initialize Error"))))))
-    (get-ffi-obj "MLOpenArgcArgv" mathlink
+    (get-ffi-obj 'MLOpenArgcArgv mathlink
                  (_fun args ::
                        (ep : _pointer = (MLInitialize))
                        (_int = (add1 (length args)))
@@ -43,116 +43,113 @@
                        -> (if lp
                               (begin (MLNextPacket lp)
                                      (MLNewPacket lp)
-                                     (make-MathLink ep lp #t (make-semaphore 1)))
+                                     (make-MathLink ep lp #t (make-semaphore 1) (make-phantom-bytes 65536)))
                               (mathlink-error "MathKernel: MathLink Open Error"))))))
 
 (define MLClose
-  (let ((MLClose
-         (let ((close (get-ffi-obj "MLClose" mathlink
-                                   (_fun _pointer -> _void))))
-           (lambda (link)
-             (MLPutMessage link 1)
-             (close link))))
+  (let ((MLClose (get-ffi-obj 'MLClose mathlink
+                              (_fun _pointer -> _void)))
         (MLDeinitialize
-         (get-ffi-obj "MLDeinitialize" mathlink
+         (get-ffi-obj 'MLDeinitialize mathlink
                       (_fun _pointer -> _void))))
     (lambda (link)
+      (MLPutMessage (MathLink-lp link) 1)
       (MLClose (MathLink-lp link))
       (MLDeinitialize (MathLink-ep link)))))
 
 (define MLPutFunction
-  (get-ffi-obj "MLPutFunction" mathlink
+  (get-ffi-obj 'MLPutFunction mathlink
                (_fun _pointer _bytes _int -> _bool)))
 
 (define MLPutArgCount
-  (get-ffi-obj "MLPutArgCount" mathlink
+  (get-ffi-obj 'MLPutArgCount mathlink
                (_fun _pointer _int -> _bool)))
 
 (define MLPutString
-  (get-ffi-obj "MLPutUTF32String" mathlink
+  (get-ffi-obj 'MLPutUTF32String mathlink
                (_fun _pointer (s : _string/ucs-4) (_int = (string-length s)) -> _bool)))
 
 (define MLPutReal
-  (get-ffi-obj "MLPutReal" mathlink
+  (get-ffi-obj 'MLPutReal mathlink
                (_fun _pointer _double -> _bool)))
 
 (define MLPutNext
-  (get-ffi-obj "MLPutNext" mathlink
+  (get-ffi-obj 'MLPutNext mathlink
                (_fun _pointer _int -> _bool)))
 
 (define MLNextPacket
-  (get-ffi-obj "MLNextPacket" mathlink
+  (get-ffi-obj 'MLNextPacket mathlink
                (_fun _pointer -> _int)))
 
 (define MLEndPacket
-  (get-ffi-obj "MLEndPacket" mathlink
+  (get-ffi-obj 'MLEndPacket mathlink
                (_fun _pointer -> _bool)))
 
 (define MLNewPacket
-  (get-ffi-obj "MLNewPacket" mathlink
+  (get-ffi-obj 'MLNewPacket mathlink
                (_fun _pointer -> _bool)))
 
 (define MLGetString
-  (let ((release (get-ffi-obj "MLReleaseUTF32String" mathlink
+  (let ((release (get-ffi-obj 'MLReleaseUTF32String mathlink
                               (_fun _pointer _pointer _int -> _void)))
-        (make (get-ffi-obj "scheme_make_sized_char_string" #f
+        (make (get-ffi-obj 'scheme_make_sized_char_string #f
                            (_fun _pointer _intptr _bool -> _scheme))))
-    (get-ffi-obj "MLGetUTF32String" mathlink
+    (get-ffi-obj 'MLGetUTF32String mathlink
                  (_fun (l : _pointer) (s : (_ptr o _pointer)) (len : (_ptr o _int)) -> _bool
                        -> (begin0 (make s len #t)
                                   (release l s len))))))
 
 (define MLGetSymbol
-  (let ((release (get-ffi-obj "MLReleaseUTF8Symbol" mathlink
+  (let ((release (get-ffi-obj 'MLReleaseUTF8Symbol mathlink
                               (_fun _pointer _pointer _int -> _void)))
-        (make (get-ffi-obj "scheme_intern_exact_symbol" #f
+        (make (get-ffi-obj 'scheme_intern_exact_symbol #f
                            (_fun _pointer _int -> _scheme))))
-    (get-ffi-obj "MLGetUTF8Symbol" mathlink
+    (get-ffi-obj 'MLGetUTF8Symbol mathlink
                  (_fun (l : _pointer) (s : (_ptr o _pointer)) (b : (_ptr o _int)) (_ptr o _int) -> _bool
                        -> (begin0 (make s b)
                                   (release l s b))))))
 
 (define MLGetInteger
-  (let ((release (get-ffi-obj "MLReleaseString" mathlink
+  (let ((release (get-ffi-obj 'MLReleaseString mathlink
                               (_fun _pointer _pointer -> _void)))
-        (make (get-ffi-obj "scheme_read_bignum_bytes" #f
+        (make (get-ffi-obj 'scheme_read_bignum_bytes #f
                            (_fun _pointer (_int = 0) (_int = 10) -> _scheme))))
-    (get-ffi-obj "MLGetString" mathlink
+    (get-ffi-obj 'MLGetString mathlink
                  (_fun (l : _pointer) (s : (_ptr o _pointer)) -> _bool
                        -> (begin0 (make s)
                                   (release l s))))))
 
 (define MLGetNext
-  (get-ffi-obj "MLGetNext" mathlink
+  (get-ffi-obj 'MLGetNext mathlink
                (_fun _pointer -> _int)))
 
 (define MLGetArgCount
-  (get-ffi-obj "MLGetArgCount" mathlink
+  (get-ffi-obj 'MLGetArgCount mathlink
                (_fun _pointer (n : (_ptr o _int)) -> _bool
                      -> n)))
 
 (define MLFlush
-  (get-ffi-obj "MLFlush" mathlink
+  (get-ffi-obj 'MLFlush mathlink
                (_fun _pointer -> _bool)))
 
 (define MLWait
-  (let ((MLReady (ffi-obj-ref "MLReady" mathlink)))
-    (get-ffi-obj "scheme_block_until_enable_break" #f
+  (let ((MLReady (ffi-obj-ref 'MLReady mathlink)))
+    (get-ffi-obj 'scheme_block_until_enable_break #f
                  (_fun (_fpointer = MLReady) (_fpointer = #f) _pointer (_float = 0.0) _bool
                        -> _bool))))
 
 (define MLPutMessage
-  (get-ffi-obj "MLPutMessage" mathlink
+  (get-ffi-obj 'MLPutMessage mathlink
                (_fun _pointer _int -> _bool)))
 
 (define MLError
-  (get-ffi-obj "MLError" mathlink
+  (get-ffi-obj 'MLError mathlink
                (_fun _pointer -> _int)))
 
 (define MLErrorMessage
-  (get-ffi-obj "MLErrorMessage" mathlink
+  (get-ffi-obj 'MLErrorMessage mathlink
                (_fun _pointer -> _string/latin-1)))
 
 (define MLClearError
-  (get-ffi-obj "MLClearError" mathlink
+  (get-ffi-obj 'MLClearError mathlink
                (_fun _pointer -> _bool)))