-
Notifications
You must be signed in to change notification settings - Fork 1
/
mathlink.ss
151 lines (128 loc) · 5.23 KB
/
mathlink.ss
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
#lang racket/base
(require ffi/unsafe)
(provide (except-out (all-defined-out)
mathlink))
(define-struct MathLink (ep (lp #:mutable) sema))
(define-struct (exn:fail:mathlink exn:fail) () #:transparent)
(define-syntax-rule (mathlink-error str)
(raise (make-exn:fail:mathlink str (current-continuation-marks))))
(define mathlink
(ffi-lib (case (system-type 'os)
((unix)
(string-append "libWSTP"
(number->string (* (compiler-sizeof '*) 8))
"i4"))
((windows)
(string-append "wstp"
(number->string (* (compiler-sizeof '*) 8))
"i4"))
((macosx)
"wstp.framework/wstp"))))
(define MLOpen
(let ((MLInitialize
(get-ffi-obj 'WSInitialize mathlink
(_fun (_pointer = #f) -> (p : _pointer)
-> (or p (mathlink-error "MathKernel: MathLink Initialize Error"))))))
(get-ffi-obj 'WSOpenArgcArgv mathlink
(_fun args ::
(ep : _pointer = (MLInitialize))
(_int = (add1 (length args)))
((_list i _string/locale) = (cons "MrMathematica" args))
(_ptr o _int)
-> (lp : _pointer)
-> (if lp
(begin (MLNextPacket lp)
(MLNewPacket lp)
(make-MathLink ep lp (make-semaphore 1)))
(mathlink-error "MathKernel: MathLink Open Error"))))))
(define MLClose
(let ((close (get-ffi-obj 'WSClose mathlink
(_fun _pointer -> _void)))
(deinitialize
(get-ffi-obj 'WSDeinitialize mathlink
(_fun _pointer -> _void))))
(lambda (link)
(let ((lp (MathLink-lp link)))
(when lp
(MLPutMessage (MathLink-lp link) 1)
(close (MathLink-lp link))
(deinitialize (MathLink-ep link))
(set-MathLink-lp! link #f))))))
(define MLPutFunction
(get-ffi-obj 'WSPutFunction mathlink
(_fun _pointer _bytes/nul-terminated _int -> _bool)))
(define MLPutArgCount
(get-ffi-obj 'WSPutArgCount mathlink
(_fun _pointer _int -> _bool)))
(define MLPutString
(get-ffi-obj 'WSPutUTF32String mathlink
(_fun (l s) ::
(l : _pointer)
(_string/ucs-4 = (string-append "\uFEFF" s))
(_int = (add1 (string-length s)))
-> _bool)))
(define MLPutReal
(get-ffi-obj 'WSPutReal mathlink
(_fun _pointer _double -> _bool)))
(define MLPutNext
(get-ffi-obj 'WSPutNext mathlink
(_fun _pointer _int -> _bool)))
(define MLNextPacket
(get-ffi-obj 'WSNextPacket mathlink
(_fun _pointer -> _int)))
(define MLEndPacket
(get-ffi-obj 'WSEndPacket mathlink
(_fun _pointer -> _bool)))
(define MLNewPacket
(get-ffi-obj 'WSNewPacket mathlink
(_fun _pointer -> _bool)))
(define MLGetString
(case (system-type 'vm)
((racket)
(let ((release (get-ffi-obj 'WSReleaseUTF32String mathlink
(_fun _pointer _pointer _int -> _void)))
(make (get-ffi-obj 'scheme_make_sized_char_string #f
(_fun _pointer _intptr _bool -> _scheme))))
(get-ffi-obj 'WSGetUTF32String mathlink
(_fun (l : _pointer) (s : (_ptr o _pointer)) (len : (_ptr o _int)) -> _bool
-> (begin0 (make (ptr-add s 4) (sub1 len) #t)
(release l s len))))))
((chez-scheme)
(let ((release (get-ffi-obj 'WSReleaseUTF8String mathlink
(_fun _pointer _pointer _int -> _void)))
(make (get-ffi-obj 'Sstring_utf8 #f
(_fun _pointer _intptr -> _scheme))))
(get-ffi-obj 'WSGetUTF8String mathlink
(_fun (l : _pointer) (s : (_ptr o _pointer)) (len : (_ptr o _int)) (_ptr o _int) -> _bool
-> (begin0 (make s len)
(release l s len))))))))
(define MLGetNext
(get-ffi-obj 'WSGetNext mathlink
(_fun _pointer -> _int)))
(define MLGetArgCount
(get-ffi-obj 'WSGetArgCount mathlink
(_fun _pointer (n : (_ptr o _int)) -> _bool
-> n)))
(define MLWait
(let ((MLFlush (get-ffi-obj 'WSFlush mathlink
(_fun _pointer -> _bool)))
(MLReady (get-ffi-obj 'WSReady mathlink
(_fun _pointer -> _bool))))
(lambda (lp)
(MLFlush lp)
(let loop ()
(unless (MLReady lp)
(sleep 0.01)
(loop))))))
(define MLPutMessage
(get-ffi-obj 'WSPutMessage mathlink
(_fun _pointer _int -> _bool)))
(define MLError
(get-ffi-obj 'WSError mathlink
(_fun _pointer -> _int)))
(define MLErrorMessage
(get-ffi-obj 'WSErrorMessage mathlink
(_fun _pointer -> _string/latin-1)))
(define MLClearError
(get-ffi-obj 'WSClearError mathlink
(_fun _pointer -> _bool)))