|
5 | 5 | (provide (except-out (all-defined-out)
|
6 | 6 | mathlink))
|
7 | 7 |
|
8 |
| -(define-struct MathLink (ep lp (ref #:mutable) sema)) |
| 8 | +(define-struct MathLink (ep lp (ref #:mutable) sema phantom)) |
9 | 9 |
|
10 | 10 | (define warning
|
11 |
| - (get-ffi-obj "scheme_warning" #f |
| 11 | + (get-ffi-obj 'scheme_warning #f |
12 | 12 | (_fun (_bytes = #"%T") _scheme -> _void)))
|
13 | 13 |
|
14 | 14 | (define-struct (exn:fail:mathlink exn:fail) () #:transparent)
|
|
30 | 30 |
|
31 | 31 | (define MLOpen
|
32 | 32 | (let ((MLInitialize
|
33 |
| - (get-ffi-obj "MLInitialize" mathlink |
| 33 | + (get-ffi-obj 'MLInitialize mathlink |
34 | 34 | (_fun (_pointer = #f) -> (p : _pointer)
|
35 | 35 | -> (or p (mathlink-error "MathKernel: MathLink Initialize Error"))))))
|
36 |
| - (get-ffi-obj "MLOpenArgcArgv" mathlink |
| 36 | + (get-ffi-obj 'MLOpenArgcArgv mathlink |
37 | 37 | (_fun args ::
|
38 | 38 | (ep : _pointer = (MLInitialize))
|
39 | 39 | (_int = (add1 (length args)))
|
|
43 | 43 | -> (if lp
|
44 | 44 | (begin (MLNextPacket lp)
|
45 | 45 | (MLNewPacket lp)
|
46 |
| - (make-MathLink ep lp #t (make-semaphore 1))) |
| 46 | + (make-MathLink ep lp #t (make-semaphore 1) (make-phantom-bytes 65536))) |
47 | 47 | (mathlink-error "MathKernel: MathLink Open Error"))))))
|
48 | 48 |
|
49 | 49 | (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))) |
56 | 52 | (MLDeinitialize
|
57 |
| - (get-ffi-obj "MLDeinitialize" mathlink |
| 53 | + (get-ffi-obj 'MLDeinitialize mathlink |
58 | 54 | (_fun _pointer -> _void))))
|
59 | 55 | (lambda (link)
|
| 56 | + (MLPutMessage (MathLink-lp link) 1) |
60 | 57 | (MLClose (MathLink-lp link))
|
61 | 58 | (MLDeinitialize (MathLink-ep link)))))
|
62 | 59 |
|
63 | 60 | (define MLPutFunction
|
64 |
| - (get-ffi-obj "MLPutFunction" mathlink |
| 61 | + (get-ffi-obj 'MLPutFunction mathlink |
65 | 62 | (_fun _pointer _bytes _int -> _bool)))
|
66 | 63 |
|
67 | 64 | (define MLPutArgCount
|
68 |
| - (get-ffi-obj "MLPutArgCount" mathlink |
| 65 | + (get-ffi-obj 'MLPutArgCount mathlink |
69 | 66 | (_fun _pointer _int -> _bool)))
|
70 | 67 |
|
71 | 68 | (define MLPutString
|
72 |
| - (get-ffi-obj "MLPutUTF32String" mathlink |
| 69 | + (get-ffi-obj 'MLPutUTF32String mathlink |
73 | 70 | (_fun _pointer (s : _string/ucs-4) (_int = (string-length s)) -> _bool)))
|
74 | 71 |
|
75 | 72 | (define MLPutReal
|
76 |
| - (get-ffi-obj "MLPutReal" mathlink |
| 73 | + (get-ffi-obj 'MLPutReal mathlink |
77 | 74 | (_fun _pointer _double -> _bool)))
|
78 | 75 |
|
79 | 76 | (define MLPutNext
|
80 |
| - (get-ffi-obj "MLPutNext" mathlink |
| 77 | + (get-ffi-obj 'MLPutNext mathlink |
81 | 78 | (_fun _pointer _int -> _bool)))
|
82 | 79 |
|
83 | 80 | (define MLNextPacket
|
84 |
| - (get-ffi-obj "MLNextPacket" mathlink |
| 81 | + (get-ffi-obj 'MLNextPacket mathlink |
85 | 82 | (_fun _pointer -> _int)))
|
86 | 83 |
|
87 | 84 | (define MLEndPacket
|
88 |
| - (get-ffi-obj "MLEndPacket" mathlink |
| 85 | + (get-ffi-obj 'MLEndPacket mathlink |
89 | 86 | (_fun _pointer -> _bool)))
|
90 | 87 |
|
91 | 88 | (define MLNewPacket
|
92 |
| - (get-ffi-obj "MLNewPacket" mathlink |
| 89 | + (get-ffi-obj 'MLNewPacket mathlink |
93 | 90 | (_fun _pointer -> _bool)))
|
94 | 91 |
|
95 | 92 | (define MLGetString
|
96 |
| - (let ((release (get-ffi-obj "MLReleaseUTF32String" mathlink |
| 93 | + (let ((release (get-ffi-obj 'MLReleaseUTF32String mathlink |
97 | 94 | (_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 |
99 | 96 | (_fun _pointer _intptr _bool -> _scheme))))
|
100 |
| - (get-ffi-obj "MLGetUTF32String" mathlink |
| 97 | + (get-ffi-obj 'MLGetUTF32String mathlink |
101 | 98 | (_fun (l : _pointer) (s : (_ptr o _pointer)) (len : (_ptr o _int)) -> _bool
|
102 | 99 | -> (begin0 (make s len #t)
|
103 | 100 | (release l s len))))))
|
104 | 101 |
|
105 | 102 | (define MLGetSymbol
|
106 |
| - (let ((release (get-ffi-obj "MLReleaseUTF8Symbol" mathlink |
| 103 | + (let ((release (get-ffi-obj 'MLReleaseUTF8Symbol mathlink |
107 | 104 | (_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 |
109 | 106 | (_fun _pointer _int -> _scheme))))
|
110 |
| - (get-ffi-obj "MLGetUTF8Symbol" mathlink |
| 107 | + (get-ffi-obj 'MLGetUTF8Symbol mathlink |
111 | 108 | (_fun (l : _pointer) (s : (_ptr o _pointer)) (b : (_ptr o _int)) (_ptr o _int) -> _bool
|
112 | 109 | -> (begin0 (make s b)
|
113 | 110 | (release l s b))))))
|
114 | 111 |
|
115 | 112 | (define MLGetInteger
|
116 |
| - (let ((release (get-ffi-obj "MLReleaseString" mathlink |
| 113 | + (let ((release (get-ffi-obj 'MLReleaseString mathlink |
117 | 114 | (_fun _pointer _pointer -> _void)))
|
118 |
| - (make (get-ffi-obj "scheme_read_bignum_bytes" #f |
| 115 | + (make (get-ffi-obj 'scheme_read_bignum_bytes #f |
119 | 116 | (_fun _pointer (_int = 0) (_int = 10) -> _scheme))))
|
120 |
| - (get-ffi-obj "MLGetString" mathlink |
| 117 | + (get-ffi-obj 'MLGetString mathlink |
121 | 118 | (_fun (l : _pointer) (s : (_ptr o _pointer)) -> _bool
|
122 | 119 | -> (begin0 (make s)
|
123 | 120 | (release l s))))))
|
124 | 121 |
|
125 | 122 | (define MLGetNext
|
126 |
| - (get-ffi-obj "MLGetNext" mathlink |
| 123 | + (get-ffi-obj 'MLGetNext mathlink |
127 | 124 | (_fun _pointer -> _int)))
|
128 | 125 |
|
129 | 126 | (define MLGetArgCount
|
130 |
| - (get-ffi-obj "MLGetArgCount" mathlink |
| 127 | + (get-ffi-obj 'MLGetArgCount mathlink |
131 | 128 | (_fun _pointer (n : (_ptr o _int)) -> _bool
|
132 | 129 | -> n)))
|
133 | 130 |
|
134 | 131 | (define MLFlush
|
135 |
| - (get-ffi-obj "MLFlush" mathlink |
| 132 | + (get-ffi-obj 'MLFlush mathlink |
136 | 133 | (_fun _pointer -> _bool)))
|
137 | 134 |
|
138 | 135 | (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 |
141 | 138 | (_fun (_fpointer = MLReady) (_fpointer = #f) _pointer (_float = 0.0) _bool
|
142 | 139 | -> _bool))))
|
143 | 140 |
|
144 | 141 | (define MLPutMessage
|
145 |
| - (get-ffi-obj "MLPutMessage" mathlink |
| 142 | + (get-ffi-obj 'MLPutMessage mathlink |
146 | 143 | (_fun _pointer _int -> _bool)))
|
147 | 144 |
|
148 | 145 | (define MLError
|
149 |
| - (get-ffi-obj "MLError" mathlink |
| 146 | + (get-ffi-obj 'MLError mathlink |
150 | 147 | (_fun _pointer -> _int)))
|
151 | 148 |
|
152 | 149 | (define MLErrorMessage
|
153 |
| - (get-ffi-obj "MLErrorMessage" mathlink |
| 150 | + (get-ffi-obj 'MLErrorMessage mathlink |
154 | 151 | (_fun _pointer -> _string/latin-1)))
|
155 | 152 |
|
156 | 153 | (define MLClearError
|
157 |
| - (get-ffi-obj "MLClearError" mathlink |
| 154 | + (get-ffi-obj 'MLClearError mathlink |
158 | 155 | (_fun _pointer -> _bool)))
|
0 commit comments