Skip to content

Commit 5def24e

Browse files
author
Chongkai Zhu
committed
add phantom
1 parent 1ae9c28 commit 5def24e

File tree

2 files changed

+38
-42
lines changed

2 files changed

+38
-42
lines changed

light.ss

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -166,9 +166,7 @@
166166
(arg
167167
(let ((link (apply MLOpen arg)))
168168
(set-MathLink-ref! link
169-
(register-custodian-shutdown link MLClose
170-
#:at-exit? #t
171-
#:weak? #t))
169+
(register-custodian-shutdown link MLClose #:at-exit? #t))
172170
(register-finalizer link MathExit)
173171
(current-mathlink link)
174172
link))))
@@ -197,4 +195,5 @@
197195
(when ref
198196
(set-MathLink-ref! link #f)
199197
(unregister-custodian-shutdown link ref)
200-
(MLClose link))))))))
198+
(MLClose link)
199+
(set-phantom-bytes! (MathLink-phantom link) 0))))))))

mathlink.ss

Lines changed: 35 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -5,10 +5,10 @@
55
(provide (except-out (all-defined-out)
66
mathlink))
77

8-
(define-struct MathLink (ep lp (ref #:mutable) sema))
8+
(define-struct MathLink (ep lp (ref #:mutable) sema phantom))
99

1010
(define warning
11-
(get-ffi-obj "scheme_warning" #f
11+
(get-ffi-obj 'scheme_warning #f
1212
(_fun (_bytes = #"%T") _scheme -> _void)))
1313

1414
(define-struct (exn:fail:mathlink exn:fail) () #:transparent)
@@ -30,10 +30,10 @@
3030

3131
(define MLOpen
3232
(let ((MLInitialize
33-
(get-ffi-obj "MLInitialize" mathlink
33+
(get-ffi-obj 'MLInitialize mathlink
3434
(_fun (_pointer = #f) -> (p : _pointer)
3535
-> (or p (mathlink-error "MathKernel: MathLink Initialize Error"))))))
36-
(get-ffi-obj "MLOpenArgcArgv" mathlink
36+
(get-ffi-obj 'MLOpenArgcArgv mathlink
3737
(_fun args ::
3838
(ep : _pointer = (MLInitialize))
3939
(_int = (add1 (length args)))
@@ -43,116 +43,113 @@
4343
-> (if lp
4444
(begin (MLNextPacket lp)
4545
(MLNewPacket lp)
46-
(make-MathLink ep lp #t (make-semaphore 1)))
46+
(make-MathLink ep lp #t (make-semaphore 1) (make-phantom-bytes 65536)))
4747
(mathlink-error "MathKernel: MathLink Open Error"))))))
4848

4949
(define MLClose
50-
(let ((MLClose
51-
(let ((close (get-ffi-obj "MLClose" mathlink
52-
(_fun _pointer -> _void))))
53-
(lambda (link)
54-
(MLPutMessage link 1)
55-
(close link))))
50+
(let ((MLClose (get-ffi-obj 'MLClose mathlink
51+
(_fun _pointer -> _void)))
5652
(MLDeinitialize
57-
(get-ffi-obj "MLDeinitialize" mathlink
53+
(get-ffi-obj 'MLDeinitialize mathlink
5854
(_fun _pointer -> _void))))
5955
(lambda (link)
56+
(MLPutMessage (MathLink-lp link) 1)
6057
(MLClose (MathLink-lp link))
6158
(MLDeinitialize (MathLink-ep link)))))
6259

6360
(define MLPutFunction
64-
(get-ffi-obj "MLPutFunction" mathlink
61+
(get-ffi-obj 'MLPutFunction mathlink
6562
(_fun _pointer _bytes _int -> _bool)))
6663

6764
(define MLPutArgCount
68-
(get-ffi-obj "MLPutArgCount" mathlink
65+
(get-ffi-obj 'MLPutArgCount mathlink
6966
(_fun _pointer _int -> _bool)))
7067

7168
(define MLPutString
72-
(get-ffi-obj "MLPutUTF32String" mathlink
69+
(get-ffi-obj 'MLPutUTF32String mathlink
7370
(_fun _pointer (s : _string/ucs-4) (_int = (string-length s)) -> _bool)))
7471

7572
(define MLPutReal
76-
(get-ffi-obj "MLPutReal" mathlink
73+
(get-ffi-obj 'MLPutReal mathlink
7774
(_fun _pointer _double -> _bool)))
7875

7976
(define MLPutNext
80-
(get-ffi-obj "MLPutNext" mathlink
77+
(get-ffi-obj 'MLPutNext mathlink
8178
(_fun _pointer _int -> _bool)))
8279

8380
(define MLNextPacket
84-
(get-ffi-obj "MLNextPacket" mathlink
81+
(get-ffi-obj 'MLNextPacket mathlink
8582
(_fun _pointer -> _int)))
8683

8784
(define MLEndPacket
88-
(get-ffi-obj "MLEndPacket" mathlink
85+
(get-ffi-obj 'MLEndPacket mathlink
8986
(_fun _pointer -> _bool)))
9087

9188
(define MLNewPacket
92-
(get-ffi-obj "MLNewPacket" mathlink
89+
(get-ffi-obj 'MLNewPacket mathlink
9390
(_fun _pointer -> _bool)))
9491

9592
(define MLGetString
96-
(let ((release (get-ffi-obj "MLReleaseUTF32String" mathlink
93+
(let ((release (get-ffi-obj 'MLReleaseUTF32String mathlink
9794
(_fun _pointer _pointer _int -> _void)))
98-
(make (get-ffi-obj "scheme_make_sized_char_string" #f
95+
(make (get-ffi-obj 'scheme_make_sized_char_string #f
9996
(_fun _pointer _intptr _bool -> _scheme))))
100-
(get-ffi-obj "MLGetUTF32String" mathlink
97+
(get-ffi-obj 'MLGetUTF32String mathlink
10198
(_fun (l : _pointer) (s : (_ptr o _pointer)) (len : (_ptr o _int)) -> _bool
10299
-> (begin0 (make s len #t)
103100
(release l s len))))))
104101

105102
(define MLGetSymbol
106-
(let ((release (get-ffi-obj "MLReleaseUTF8Symbol" mathlink
103+
(let ((release (get-ffi-obj 'MLReleaseUTF8Symbol mathlink
107104
(_fun _pointer _pointer _int -> _void)))
108-
(make (get-ffi-obj "scheme_intern_exact_symbol" #f
105+
(make (get-ffi-obj 'scheme_intern_exact_symbol #f
109106
(_fun _pointer _int -> _scheme))))
110-
(get-ffi-obj "MLGetUTF8Symbol" mathlink
107+
(get-ffi-obj 'MLGetUTF8Symbol mathlink
111108
(_fun (l : _pointer) (s : (_ptr o _pointer)) (b : (_ptr o _int)) (_ptr o _int) -> _bool
112109
-> (begin0 (make s b)
113110
(release l s b))))))
114111

115112
(define MLGetInteger
116-
(let ((release (get-ffi-obj "MLReleaseString" mathlink
113+
(let ((release (get-ffi-obj 'MLReleaseString mathlink
117114
(_fun _pointer _pointer -> _void)))
118-
(make (get-ffi-obj "scheme_read_bignum_bytes" #f
115+
(make (get-ffi-obj 'scheme_read_bignum_bytes #f
119116
(_fun _pointer (_int = 0) (_int = 10) -> _scheme))))
120-
(get-ffi-obj "MLGetString" mathlink
117+
(get-ffi-obj 'MLGetString mathlink
121118
(_fun (l : _pointer) (s : (_ptr o _pointer)) -> _bool
122119
-> (begin0 (make s)
123120
(release l s))))))
124121

125122
(define MLGetNext
126-
(get-ffi-obj "MLGetNext" mathlink
123+
(get-ffi-obj 'MLGetNext mathlink
127124
(_fun _pointer -> _int)))
128125

129126
(define MLGetArgCount
130-
(get-ffi-obj "MLGetArgCount" mathlink
127+
(get-ffi-obj 'MLGetArgCount mathlink
131128
(_fun _pointer (n : (_ptr o _int)) -> _bool
132129
-> n)))
133130

134131
(define MLFlush
135-
(get-ffi-obj "MLFlush" mathlink
132+
(get-ffi-obj 'MLFlush mathlink
136133
(_fun _pointer -> _bool)))
137134

138135
(define MLWait
139-
(let ((MLReady (ffi-obj-ref "MLReady" mathlink)))
140-
(get-ffi-obj "scheme_block_until_enable_break" #f
136+
(let ((MLReady (ffi-obj-ref 'MLReady mathlink)))
137+
(get-ffi-obj 'scheme_block_until_enable_break #f
141138
(_fun (_fpointer = MLReady) (_fpointer = #f) _pointer (_float = 0.0) _bool
142139
-> _bool))))
143140

144141
(define MLPutMessage
145-
(get-ffi-obj "MLPutMessage" mathlink
142+
(get-ffi-obj 'MLPutMessage mathlink
146143
(_fun _pointer _int -> _bool)))
147144

148145
(define MLError
149-
(get-ffi-obj "MLError" mathlink
146+
(get-ffi-obj 'MLError mathlink
150147
(_fun _pointer -> _int)))
151148

152149
(define MLErrorMessage
153-
(get-ffi-obj "MLErrorMessage" mathlink
150+
(get-ffi-obj 'MLErrorMessage mathlink
154151
(_fun _pointer -> _string/latin-1)))
155152

156153
(define MLClearError
157-
(get-ffi-obj "MLClearError" mathlink
154+
(get-ffi-obj 'MLClearError mathlink
158155
(_fun _pointer -> _bool)))

0 commit comments

Comments
 (0)