55212af1 |
1 | ;; Common Lisp bindings for GTK+ v2.x |
2 | ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net> |
fc358945 |
3 | ;; |
55212af1 |
4 | ;; Permission is hereby granted, free of charge, to any person obtaining |
5 | ;; a copy of this software and associated documentation files (the |
6 | ;; "Software"), to deal in the Software without restriction, including |
7 | ;; without limitation the rights to use, copy, modify, merge, publish, |
8 | ;; distribute, sublicense, and/or sell copies of the Software, and to |
9 | ;; permit persons to whom the Software is furnished to do so, subject to |
10 | ;; the following conditions: |
fc358945 |
11 | ;; |
55212af1 |
12 | ;; The above copyright notice and this permission notice shall be |
13 | ;; included in all copies or substantial portions of the Software. |
fc358945 |
14 | ;; |
55212af1 |
15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, |
16 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF |
17 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. |
18 | ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY |
19 | ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, |
20 | ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE |
21 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |
22 | |
23 | ;; $Id: ffi.lisp,v 1.20 2005/04/23 16:48:50 espen Exp $ |
fc358945 |
24 | |
25 | (in-package "GLIB") |
26 | |
fc358945 |
27 | |
28 | ;;;; Foreign function call interface |
29 | |
30 | (defvar *package-prefix* nil) |
31 | |
32 | (defun set-package-prefix (prefix &optional (package *package*)) |
33 | (let ((package (find-package package))) |
34 | (delete-if #'(lambda (assoc) (eq (car assoc) package)) *package-prefix*) |
35 | (push (cons package prefix) *package-prefix*)) |
36 | prefix) |
37 | |
38 | (defun package-prefix (&optional (package *package*)) |
39 | (let ((package (find-package package))) |
40 | (or |
41 | (cdr (assoc package *package-prefix*)) |
42 | (substitute #\_ #\- (string-downcase (package-name package)))))) |
43 | |
44 | (defun find-prefix-package (prefix) |
45 | (or |
46 | (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=)) |
47 | (find-package (string-upcase prefix)))) |
48 | |
49 | (defmacro use-prefix (prefix &optional (package *package*)) |
50 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
51 | (set-package-prefix ,prefix ,package))) |
52 | |
53 | |
54 | (defun default-alien-fname (lisp-name) |
58ddfaac |
55 | (let* ((name (substitute #\_ #\- (string-downcase lisp-name))) |
56 | (stripped-name |
57 | (cond |
58 | ((and |
59 | (char= (char name 0) #\%) |
60 | (string= "_p" name :start2 (- (length name) 2))) |
61 | (subseq name 1 (- (length name) 2))) |
62 | ((char= (char name 0) #\%) |
63 | (subseq name 1)) |
64 | ((string= "_p" name :start2 (- (length name) 2)) |
65 | (subseq name 0 (- (length name) 2))) |
66 | (name))) |
67 | (prefix (package-prefix *package*))) |
fc358945 |
68 | (if (or (not prefix) (string= prefix "")) |
58ddfaac |
69 | stripped-name |
70 | (format nil "~A_~A" prefix stripped-name)))) |
fc358945 |
71 | |
72 | (defun default-alien-type-name (type-name) |
73 | (let ((prefix (package-prefix *package*))) |
74 | (apply |
75 | #'concatenate |
76 | 'string |
77 | (mapcar |
78 | #'string-capitalize |
79 | (cons prefix (split-string (symbol-name type-name) #\-)))))) |
80 | |
81 | (defun default-type-name (alien-name) |
82 | (let ((parts |
83 | (mapcar |
84 | #'string-upcase |
85 | (split-string-if alien-name #'upper-case-p)))) |
86 | (intern |
87 | (concatenate-strings |
88 | (rest parts) #\-) (find-prefix-package (first parts))))) |
89 | |
90 | |
6baf860c |
91 | (defmacro defbinding (name lambda-list return-type &rest docs/args) |
fc358945 |
92 | (multiple-value-bind (lisp-name c-name) |
93 | (if (atom name) |
94 | (values name (default-alien-fname name)) |
95 | (values-list name)) |
96 | |
97 | (let ((supplied-lambda-list lambda-list) |
98 | (docs nil) |
99 | (args nil)) |
100 | (dolist (doc/arg docs/args) |
101 | (if (stringp doc/arg) |
102 | (push doc/arg docs) |
103 | (progn |
104 | (destructuring-bind (expr type &optional (style :in)) doc/arg |
6cb19a68 |
105 | (unless (member style '(:in :out :in-out :return)) |
fc358945 |
106 | (error "Bogus argument style ~S in ~S." style doc/arg)) |
107 | (when (and |
108 | (not supplied-lambda-list) |
6cb19a68 |
109 | (namep expr) (member style '(:in :in-out :return))) |
fc358945 |
110 | (push expr lambda-list)) |
e37c4285 |
111 | (push (list (cond |
112 | ((and (namep expr) (eq style :out)) expr) |
113 | ((namep expr) (make-symbol (string expr))) |
114 | ((gensym))) |
115 | expr (mklist type) style) args))))) |
fc358945 |
116 | |
117 | (%defbinding |
118 | c-name lisp-name (or supplied-lambda-list (nreverse lambda-list)) |
6baf860c |
119 | return-type (reverse docs) (reverse args))))) |
fc358945 |
120 | |
3d36c5d6 |
121 | #+(or cmu sbcl) |
6baf860c |
122 | (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args) |
3d36c5d6 |
123 | (collect ((alien-types) (alien-bindings) (alien-parameters) |
124 | (return-values) (cleanup-forms)) |
fc358945 |
125 | (dolist (arg args) |
6baf860c |
126 | (destructuring-bind (var expr type style) arg |
127 | (let ((declaration (alien-type type)) |
128 | (cleanup (cleanup-form var type))) |
129 | |
fc358945 |
130 | (cond |
6cb19a68 |
131 | ((member style '(:out :in-out)) |
132 | (alien-types `(* ,declaration)) |
133 | (alien-parameters `(addr ,var)) |
134 | (alien-bindings |
135 | `(,var ,declaration |
4eac8484 |
136 | ,@(cond |
137 | ((eq style :in-out) (list (to-alien-form expr type))) |
138 | ((eq declaration 'system-area-pointer) |
139 | (list '(make-pointer 0)))))) |
6cb19a68 |
140 | (return-values (from-alien-form var type))) |
141 | ((eq style :return) |
142 | (alien-types declaration) |
143 | (alien-bindings |
144 | `(,var ,declaration ,(to-alien-form expr type))) |
145 | (alien-parameters var) |
146 | (return-values (from-alien-form var type))) |
147 | (cleanup |
148 | (alien-types declaration) |
149 | (alien-bindings |
150 | `(,var ,declaration ,(to-alien-form expr type))) |
151 | (alien-parameters var) |
152 | (cleanup-forms cleanup)) |
153 | (t |
154 | (alien-types declaration) |
155 | (alien-parameters (to-alien-form expr type))))))) |
fc358945 |
156 | |
157 | (let* ((alien-name (make-symbol (string lisp-name))) |
158 | (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters)))) |
159 | `(defun ,lisp-name ,lambda-list |
160 | ,@docs |
3d36c5d6 |
161 | #+cmu(declare (optimize (inhibit-warnings 3))) |
162 | #+sbcl(declare (muffle-conditions compiler-note)) |
fc358945 |
163 | (with-alien ((,alien-name |
164 | (function |
6baf860c |
165 | ,(alien-type return-type) |
fc358945 |
166 | ,@(alien-types)) |
167 | :extern ,foreign-name) |
168 | ,@(alien-bindings)) |
6baf860c |
169 | ,(if return-type |
170 | `(values |
171 | (unwind-protect |
172 | ,(from-alien-form alien-funcall return-type) |
173 | ,@(cleanup-forms)) |
6cb19a68 |
174 | ,@(return-values)) |
fc358945 |
175 | `(progn |
6baf860c |
176 | (unwind-protect |
177 | ,alien-funcall |
178 | ,@(cleanup-forms)) |
6cb19a68 |
179 | (values ,@(return-values))))))))) |
fc358945 |
180 | |
181 | |
6baf860c |
182 | ;;; Creates bindings at runtime |
fc358945 |
183 | (defun mkbinding (name return-type &rest arg-types) |
3d36c5d6 |
184 | #+cmu(declare (optimize (inhibit-warnings 3))) |
185 | #+sbcl(declare (muffle-conditions compiler-note)) |
6baf860c |
186 | (let* ((ftype |
187 | `(function ,@(mapcar #'alien-type (cons return-type arg-types)))) |
fc358945 |
188 | (alien |
3d36c5d6 |
189 | (%heap-alien |
190 | (make-heap-alien-info |
191 | :type (parse-alien-type ftype #+sbcl nil) |
192 | :sap-form (foreign-symbol-address name)))) |
6baf860c |
193 | (translate-arguments (mapcar #'to-alien-function arg-types)) |
194 | (translate-return-value (from-alien-function return-type)) |
195 | (cleanup-arguments (mapcar #'cleanup-function arg-types))) |
196 | |
fc358945 |
197 | #'(lambda (&rest args) |
198 | (map-into args #'funcall translate-arguments args) |
199 | (prog1 |
6baf860c |
200 | (funcall translate-return-value |
3d36c5d6 |
201 | (apply #'alien-funcall alien args)) |
fc358945 |
202 | (mapc #'funcall cleanup-arguments args))))) |
203 | |
7bde5a67 |
204 | |
205 | (defmacro defcallback (name (return-type &rest args) &body body) |
3d36c5d6 |
206 | (let ((def-callback #+cmu'alien:def-callback |
207 | #+sbcl'sb-alien:define-alien-function)) |
208 | `(,def-callback ,name |
209 | (,(alien-type return-type) |
210 | ,@(mapcar #'(lambda (arg) |
211 | (destructuring-bind (name type) arg |
212 | `(,name ,(alien-type type)))) |
213 | args)) |
214 | ,(to-alien-form |
7aa45361 |
215 | `(let (,@(delete nil |
216 | (mapcar #'(lambda (arg) |
217 | (destructuring-bind (name type) arg |
218 | (let ((from-alien |
219 | (from-alien-form name type))) |
220 | (unless (eq name from-alien) |
221 | `(,name ,from-alien))))) |
222 | args))) |
3d36c5d6 |
223 | ,@body) |
224 | return-type)))) |
225 | |
226 | #+sbcl |
227 | (defun callback (af) |
228 | (sb-alien:alien-function-sap af)) |
7bde5a67 |
229 | |
7aa45361 |
230 | #+sbcl |
231 | (deftype callback () 'sb-alien:alien-function) |
fc358945 |
232 | |
233 | ;;;; Definitons and translations of fundamental types |
234 | |
6baf860c |
235 | (defmacro def-type-method (name args &optional documentation) |
236 | `(progn |
237 | (defgeneric ,name (,@args type &rest args) |
238 | ,@(when documentation `((:documentation ,documentation)))) |
239 | (defmethod ,name (,@args (type symbol) &rest args) |
240 | (let ((class (find-class type nil))) |
241 | (if class |
242 | (apply #',name ,@args class args) |
243 | (multiple-value-bind (super-type expanded-p) |
244 | (type-expand-1 (cons type args)) |
245 | (if expanded-p |
246 | (,name ,@args super-type) |
247 | (call-next-method)))))) |
248 | (defmethod ,name (,@args (type cons) &rest args) |
249 | (declare (ignore args)) |
250 | (apply #',name ,@args (first type) (rest type))))) |
251 | |
fc358945 |
252 | |
6baf860c |
253 | (def-type-method alien-type ()) |
254 | (def-type-method size-of ()) |
255 | (def-type-method to-alien-form (form)) |
256 | (def-type-method from-alien-form (form)) |
257 | (def-type-method cleanup-form (form) |
258 | "Creates a form to clean up after the alien call has finished.") |
fc358945 |
259 | |
6baf860c |
260 | (def-type-method to-alien-function ()) |
261 | (def-type-method from-alien-function ()) |
262 | (def-type-method cleanup-function ()) |
fc358945 |
263 | |
508d13a7 |
264 | (def-type-method copy-to-alien-form (form)) |
265 | (def-type-method copy-to-alien-function ()) |
266 | (def-type-method copy-from-alien-form (form)) |
267 | (def-type-method copy-from-alien-function ()) |
268 | |
6baf860c |
269 | (def-type-method writer-function ()) |
270 | (def-type-method reader-function ()) |
271 | (def-type-method destroy-function ()) |
fc358945 |
272 | |
b6bf802c |
273 | (def-type-method unbound-value () |
274 | "First return value is true if the type has an unbound value, second return value is the actual unbound value") |
275 | |
fc358945 |
276 | |
7bde5a67 |
277 | ;; Sizes of fundamental C types in bytes (8 bits) |
278 | (defconstant +size-of-short+ 2) |
279 | (defconstant +size-of-int+ 4) |
280 | (defconstant +size-of-long+ 4) |
281 | (defconstant +size-of-pointer+ 4) |
282 | (defconstant +size-of-float+ 4) |
283 | (defconstant +size-of-double+ 8) |
284 | |
285 | ;; Sizes of fundamental C types in bits |
286 | (defconstant +bits-of-byte+ 8) |
287 | (defconstant +bits-of-short+ 16) |
288 | (defconstant +bits-of-int+ 32) |
289 | (defconstant +bits-of-long+ 32) |
290 | |
291 | |
6baf860c |
292 | (deftype int () '(signed-byte #.+bits-of-int+)) |
293 | (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+)) |
294 | (deftype long () '(signed-byte #.+bits-of-long+)) |
295 | (deftype unsigned-long () '(unsigned-byte #.+bits-of-long+)) |
296 | (deftype short () '(signed-byte #.+bits-of-short+)) |
297 | (deftype unsigned-short () '(unsigned-byte #.+bits-of-short+)) |
298 | (deftype signed (&optional (size '*)) `(signed-byte ,size)) |
299 | (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size)) |
300 | (deftype char () 'base-char) |
301 | (deftype pointer () 'system-area-pointer) |
302 | (deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil)) |
303 | ;(deftype invalid () nil) |
fc358945 |
304 | |
305 | |
6baf860c |
306 | (defmethod to-alien-form (form (type t) &rest args) |
307 | (declare (ignore type args)) |
308 | form) |
fc358945 |
309 | |
6baf860c |
310 | (defmethod to-alien-function ((type t) &rest args) |
311 | (declare (ignore type args)) |
312 | #'identity) |
fc358945 |
313 | |
6baf860c |
314 | (defmethod from-alien-form (form (type t) &rest args) |
315 | (declare (ignore type args)) |
316 | form) |
fc358945 |
317 | |
6baf860c |
318 | (defmethod from-alien-function ((type t) &rest args) |
319 | (declare (ignore type args)) |
320 | #'identity) |
321 | |
322 | (defmethod cleanup-form (form (type t) &rest args) |
323 | (declare (ignore form type args)) |
324 | nil) |
fc358945 |
325 | |
6baf860c |
326 | (defmethod cleanup-function ((type t) &rest args) |
327 | (declare (ignore type args)) |
328 | #'identity) |
329 | |
330 | (defmethod destroy-function ((type t) &rest args) |
331 | (declare (ignore type args)) |
4c795125 |
332 | #'(lambda (location &optional offset) |
6baf860c |
333 | (declare (ignore location offset)))) |
334 | |
508d13a7 |
335 | (defmethod copy-to-alien-form (form (type t) &rest args) |
336 | (apply #'to-alien-form form type args)) |
337 | |
338 | (defmethod copy-to-alien-function ((type t) &rest args) |
339 | (apply #'to-alien-function type args)) |
340 | |
341 | (defmethod copy-from-alien-form (form (type t) &rest args) |
342 | (apply #'from-alien-form form type args)) |
343 | |
344 | (defmethod copy-from-alien-function ((type t) &rest args) |
345 | (apply #'from-alien-function type args)) |
346 | |
6baf860c |
347 | |
348 | (defmethod alien-type ((type (eql 'signed-byte)) &rest args) |
349 | (declare (ignore type)) |
350 | (destructuring-bind (&optional (size '*)) args |
351 | (ecase size |
3d36c5d6 |
352 | (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8)) |
353 | (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short) |
354 | ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int) |
355 | (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long)))) |
6baf860c |
356 | |
357 | (defmethod size-of ((type (eql 'signed-byte)) &rest args) |
358 | (declare (ignore type)) |
359 | (destructuring-bind (&optional (size '*)) args |
360 | (ecase size |
361 | (#.+bits-of-byte+ 1) |
362 | (#.+bits-of-short+ +size-of-short+) |
363 | ((* #.+bits-of-int+) +size-of-int+) |
364 | (#.+bits-of-long+ +size-of-long+)))) |
365 | |
b6bf802c |
366 | (defmethod unbound-value ((type t) &rest args) |
367 | (declare (ignore type args)) |
368 | nil) |
369 | |
6baf860c |
370 | (defmethod writer-function ((type (eql 'signed-byte)) &rest args) |
371 | (declare (ignore type)) |
372 | (destructuring-bind (&optional (size '*)) args |
373 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
374 | (ecase size |
375 | (8 #'(lambda (value location &optional (offset 0)) |
376 | (setf (signed-sap-ref-8 location offset) value))) |
377 | (16 #'(lambda (value location &optional (offset 0)) |
378 | (setf (signed-sap-ref-16 location offset) value))) |
379 | (32 #'(lambda (value location &optional (offset 0)) |
380 | (setf (signed-sap-ref-32 location offset) value))) |
381 | (64 #'(lambda (value location &optional (offset 0)) |
382 | (setf (signed-sap-ref-64 location offset) value))))))) |
383 | |
384 | (defmethod reader-function ((type (eql 'signed-byte)) &rest args) |
385 | (declare (ignore type)) |
386 | (destructuring-bind (&optional (size '*)) args |
387 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
388 | (ecase size |
389 | (8 #'(lambda (sap &optional (offset 0)) |
390 | (signed-sap-ref-8 sap offset))) |
391 | (16 #'(lambda (sap &optional (offset 0)) |
392 | (signed-sap-ref-16 sap offset))) |
393 | (32 #'(lambda (sap &optional (offset 0)) |
394 | (signed-sap-ref-32 sap offset))) |
395 | (64 #'(lambda (sap &optional (offset 0)) |
396 | (signed-sap-ref-64 sap offset))))))) |
397 | |
398 | (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args) |
399 | (destructuring-bind (&optional (size '*)) args |
400 | (ecase size |
3d36c5d6 |
401 | (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8)) |
402 | (#.+bits-of-short+ #+cmu 'c-call:unsigned-short |
403 | #+sbcl 'sb-alien:unsigned-short) |
404 | ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int |
405 | #+sbcl 'sb-alien:unsigned-int) |
406 | (#.+bits-of-long+ #+cmu 'c-call:unsigned-long |
407 | #+sbcl 'sb-alien:unsigned-long)))) |
6baf860c |
408 | |
409 | (defmethod size-of ((type (eql 'unsigned-byte)) &rest args) |
410 | (apply #'size-of 'signed args)) |
411 | |
412 | (defmethod writer-function ((type (eql 'unsigned-byte)) &rest args) |
413 | (declare (ignore type)) |
414 | (destructuring-bind (&optional (size '*)) args |
415 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
416 | (ecase size |
417 | (8 #'(lambda (value location &optional (offset 0)) |
418 | (setf (sap-ref-8 location offset) value))) |
419 | (16 #'(lambda (value location &optional (offset 0)) |
420 | (setf (sap-ref-16 location offset) value))) |
421 | (32 #'(lambda (value location &optional (offset 0)) |
422 | (setf (sap-ref-32 location offset) value))) |
423 | (64 #'(lambda (value location &optional (offset 0)) |
424 | (setf (sap-ref-64 location offset) value))))))) |
425 | |
426 | (defmethod reader-function ((type (eql 'unsigned-byte)) &rest args) |
427 | (declare (ignore type)) |
428 | (destructuring-bind (&optional (size '*)) args |
429 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
430 | (ecase size |
431 | (8 #'(lambda (sap &optional (offset 0)) |
432 | (sap-ref-8 sap offset))) |
433 | (16 #'(lambda (sap &optional (offset 0)) |
434 | (sap-ref-16 sap offset))) |
435 | (32 #'(lambda (sap &optional (offset 0)) |
436 | (sap-ref-32 sap offset))) |
437 | (64 #'(lambda (sap &optional (offset 0)) |
438 | (sap-ref-64 sap offset))))))) |
439 | |
440 | |
441 | (defmethod alien-type ((type (eql 'integer)) &rest args) |
442 | (declare (ignore type args)) |
443 | (alien-type 'signed-byte)) |
fc358945 |
444 | |
6baf860c |
445 | (defmethod size-of ((type (eql 'integer)) &rest args) |
446 | (declare (ignore type args)) |
447 | (size-of 'signed-byte)) |
fc358945 |
448 | |
42c6b247 |
449 | (defmethod writer-function ((type (eql 'integer)) &rest args) |
450 | (declare (ignore type args)) |
451 | (writer-function 'signed-byte)) |
452 | |
453 | (defmethod reader-function ((type (eql 'integer)) &rest args) |
454 | (declare (ignore type args)) |
455 | (reader-function 'signed-byte)) |
456 | |
fc358945 |
457 | |
6baf860c |
458 | (defmethod alien-type ((type (eql 'fixnum)) &rest args) |
459 | (declare (ignore type args)) |
460 | (alien-type 'signed-byte)) |
fc358945 |
461 | |
6baf860c |
462 | (defmethod size-of ((type (eql 'fixnum)) &rest args) |
463 | (declare (ignore type args)) |
464 | (size-of 'signed-byte)) |
fc358945 |
465 | |
466 | |
6baf860c |
467 | (defmethod alien-type ((type (eql 'single-float)) &rest args) |
468 | (declare (ignore type args)) |
3d36c5d6 |
469 | #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float) |
fc358945 |
470 | |
6baf860c |
471 | (defmethod size-of ((type (eql 'single-float)) &rest args) |
472 | (declare (ignore type args)) |
fc358945 |
473 | +size-of-float+) |
474 | |
472e1aae |
475 | (defmethod to-alien-form (form (type (eql 'single-float)) &rest args) |
476 | (declare (ignore type args)) |
477 | `(coerce ,form 'single-float)) |
478 | |
479 | (defmethod to-alien-function ((type (eql 'single-float)) &rest args) |
480 | (declare (ignore type args)) |
481 | #'(lambda (number) |
482 | (coerce number 'single-float))) |
483 | |
6baf860c |
484 | (defmethod writer-function ((type (eql 'single-float)) &rest args) |
485 | (declare (ignore type args)) |
486 | #'(lambda (value location &optional (offset 0)) |
7bde5a67 |
487 | (setf (sap-ref-single location offset) (coerce value 'single-float)))) |
fc358945 |
488 | |
6baf860c |
489 | (defmethod reader-function ((type (eql 'single-float)) &rest args) |
490 | (declare (ignore type args)) |
491 | #'(lambda (sap &optional (offset 0)) |
492 | (sap-ref-single sap offset))) |
fc358945 |
493 | |
494 | |
6baf860c |
495 | (defmethod alien-type ((type (eql 'double-float)) &rest args) |
496 | (declare (ignore type args)) |
3d36c5d6 |
497 | #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float) |
fc358945 |
498 | |
6baf860c |
499 | (defmethod size-of ((type (eql 'double-float)) &rest args) |
500 | (declare (ignore type args)) |
5b50f177 |
501 | +size-of-double+) |
fc358945 |
502 | |
472e1aae |
503 | (defmethod to-alien-form (form (type (eql 'double-float)) &rest args) |
504 | (declare (ignore type args)) |
505 | `(coerce ,form 'double-float)) |
506 | |
507 | (defmethod to-alien-function ((type (eql 'double-float)) &rest args) |
508 | (declare (ignore type args)) |
509 | #'(lambda (number) |
510 | (coerce number 'double-float))) |
511 | |
6baf860c |
512 | (defmethod writer-function ((type (eql 'double-float)) &rest args) |
513 | (declare (ignore type args)) |
514 | #'(lambda (value location &optional (offset 0)) |
515 | (setf (sap-ref-double location offset) (coerce value 'double-float)))) |
fc358945 |
516 | |
6baf860c |
517 | (defmethod reader-function ((type (eql 'double-float)) &rest args) |
518 | (declare (ignore type args)) |
519 | #'(lambda (sap &optional (offset 0)) |
520 | (sap-ref-double sap offset))) |
fc358945 |
521 | |
522 | |
6baf860c |
523 | (defmethod alien-type ((type (eql 'base-char)) &rest args) |
524 | (declare (ignore type args)) |
3d36c5d6 |
525 | #+cmu 'c-call:char #+sbcl 'sb-alien:char) |
fc358945 |
526 | |
6baf860c |
527 | (defmethod size-of ((type (eql 'base-char)) &rest args) |
528 | (declare (ignore type args)) |
fc358945 |
529 | 1) |
530 | |
6baf860c |
531 | (defmethod writer-function ((type (eql 'base-char)) &rest args) |
532 | (declare (ignore type args)) |
533 | #'(lambda (char location &optional (offset 0)) |
534 | (setf (sap-ref-8 location offset) (char-code char)))) |
fc358945 |
535 | |
6baf860c |
536 | (defmethod reader-function ((type (eql 'base-char)) &rest args) |
537 | (declare (ignore type args)) |
538 | #'(lambda (location &optional (offset 0)) |
539 | (code-char (sap-ref-8 location offset)))) |
fc358945 |
540 | |
541 | |
6baf860c |
542 | (defmethod alien-type ((type (eql 'string)) &rest args) |
543 | (declare (ignore type args)) |
544 | (alien-type 'pointer)) |
fc358945 |
545 | |
6baf860c |
546 | (defmethod size-of ((type (eql 'string)) &rest args) |
547 | (declare (ignore type args)) |
548 | (size-of 'pointer)) |
fc358945 |
549 | |
6baf860c |
550 | (defmethod to-alien-form (string (type (eql 'string)) &rest args) |
551 | (declare (ignore type args)) |
fc358945 |
552 | `(let ((string ,string)) |
553 | ;; Always copy strings to prevent seg fault due to GC |
a9bb8f02 |
554 | #+cmu |
fc358945 |
555 | (copy-memory |
3d36c5d6 |
556 | (vector-sap (coerce string 'simple-base-string)) |
a9bb8f02 |
557 | (1+ (length string))) |
558 | #+sbcl |
559 | (let ((utf8 (%deport-utf8-string string))) |
560 | (copy-memory (vector-sap utf8) (length utf8))))) |
fc358945 |
561 | |
6baf860c |
562 | (defmethod to-alien-function ((type (eql 'string)) &rest args) |
563 | (declare (ignore type args)) |
564 | #'(lambda (string) |
a9bb8f02 |
565 | #+cmu |
6baf860c |
566 | (copy-memory |
3d36c5d6 |
567 | (vector-sap (coerce string 'simple-base-string)) |
a9bb8f02 |
568 | (1+ (length string))) |
569 | #+sbcl |
570 | (let ((utf8 (%deport-utf8-string string))) |
571 | (copy-memory (vector-sap utf8) (length utf8))))) |
6baf860c |
572 | |
573 | (defmethod from-alien-form (string (type (eql 'string)) &rest args) |
574 | (declare (ignore type args)) |
575 | `(let ((string ,string)) |
576 | (unless (null-pointer-p string) |
508d13a7 |
577 | (prog1 |
a9bb8f02 |
578 | #+cmu(%naturalize-c-string string) |
579 | #+sbcl(%naturalize-utf8-string string) |
508d13a7 |
580 | (deallocate-memory string))))) |
fc358945 |
581 | |
6baf860c |
582 | (defmethod from-alien-function ((type (eql 'string)) &rest args) |
583 | (declare (ignore type args)) |
584 | #'(lambda (string) |
585 | (unless (null-pointer-p string) |
508d13a7 |
586 | (prog1 |
a9bb8f02 |
587 | #+cmu(%naturalize-c-string string) |
588 | #+sbcl(%naturalize-utf8-string string) |
508d13a7 |
589 | (deallocate-memory string))))) |
fc358945 |
590 | |
6baf860c |
591 | (defmethod cleanup-form (string (type (eql 'string)) &rest args) |
592 | (declare (ignore type args)) |
593 | `(let ((string ,string)) |
594 | (unless (null-pointer-p string) |
595 | (deallocate-memory string)))) |
596 | |
597 | (defmethod cleanup-function ((type (eql 'string)) &rest args) |
7bde5a67 |
598 | (declare (ignore args)) |
6baf860c |
599 | #'(lambda (string) |
600 | (unless (null-pointer-p string) |
601 | (deallocate-memory string)))) |
602 | |
508d13a7 |
603 | (defmethod copy-from-alien-form (string (type (eql 'string)) &rest args) |
604 | (declare (ignore type args)) |
605 | `(let ((string ,string)) |
606 | (unless (null-pointer-p string) |
a9bb8f02 |
607 | #+cmu(%naturalize-c-string string) |
608 | #+sbcl(%naturalize-utf8-string string)))) |
508d13a7 |
609 | |
610 | (defmethod copy-from-alien-function ((type (eql 'string)) &rest args) |
611 | (declare (ignore type args)) |
612 | #'(lambda (string) |
613 | (unless (null-pointer-p string) |
a9bb8f02 |
614 | #+cmu(%naturalize-c-string string) |
615 | #+sbcl(%naturalize-utf8-string string)))) |
508d13a7 |
616 | |
6baf860c |
617 | (defmethod writer-function ((type (eql 'string)) &rest args) |
618 | (declare (ignore type args)) |
619 | #'(lambda (string location &optional (offset 0)) |
620 | (assert (null-pointer-p (sap-ref-sap location offset))) |
621 | (setf (sap-ref-sap location offset) |
a9bb8f02 |
622 | #+cmu |
6baf860c |
623 | (copy-memory |
3d36c5d6 |
624 | (vector-sap (coerce string 'simple-base-string)) |
a9bb8f02 |
625 | (1+ (length string))) |
626 | #+sbcl |
627 | (let ((utf8 (%deport-utf8-string string))) |
628 | (copy-memory (vector-sap utf8) (length utf8)))))) |
6baf860c |
629 | |
630 | (defmethod reader-function ((type (eql 'string)) &rest args) |
631 | (declare (ignore type args)) |
632 | #'(lambda (location &optional (offset 0)) |
633 | (unless (null-pointer-p (sap-ref-sap location offset)) |
a9bb8f02 |
634 | #+cmu(%naturalize-c-string (sap-ref-sap location offset)) |
635 | #+sbcl(%naturalize-utf8-string (sap-ref-sap location offset))))) |
6baf860c |
636 | |
637 | (defmethod destroy-function ((type (eql 'string)) &rest args) |
638 | (declare (ignore type args)) |
639 | #'(lambda (location &optional (offset 0)) |
640 | (unless (null-pointer-p (sap-ref-sap location offset)) |
641 | (deallocate-memory (sap-ref-sap location offset)) |
642 | (setf (sap-ref-sap location offset) (make-pointer 0))))) |
643 | |
b6bf802c |
644 | (defmethod unbound-value ((type (eql 'string)) &rest args) |
645 | (declare (ignore type args)) |
646 | (values t nil)) |
6baf860c |
647 | |
a9bb8f02 |
648 | |
6baf860c |
649 | (defmethod alien-type ((type (eql 'pathname)) &rest args) |
650 | (declare (ignore type args)) |
651 | (alien-type 'string)) |
652 | |
653 | (defmethod size-of ((type (eql 'pathname)) &rest args) |
654 | (declare (ignore type args)) |
655 | (size-of 'string)) |
fc358945 |
656 | |
6baf860c |
657 | (defmethod to-alien-form (path (type (eql 'pathname)) &rest args) |
658 | (declare (ignore type args)) |
659 | (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string)) |
660 | |
661 | (defmethod to-alien-function ((type (eql 'pathname)) &rest args) |
662 | (declare (ignore type args)) |
663 | (let ((string-function (to-alien-function 'string))) |
664 | #'(lambda (path) |
665 | (funcall string-function (namestring path))))) |
666 | |
667 | (defmethod from-alien-form (string (type (eql 'pathname)) &rest args) |
668 | (declare (ignore type args)) |
669 | `(parse-namestring ,(from-alien-form string 'string))) |
670 | |
671 | (defmethod from-alien-function ((type (eql 'pathname)) &rest args) |
672 | (declare (ignore type args)) |
673 | (let ((string-function (from-alien-function 'string))) |
674 | #'(lambda (string) |
675 | (parse-namestring (funcall string-function string))))) |
676 | |
677 | (defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args) |
678 | (declare (ignore type args)) |
679 | (cleanup-form string 'string)) |
680 | |
681 | (defmethod cleanup-function ((type (eql 'pathnanme)) &rest args) |
682 | (declare (ignore type args)) |
683 | (cleanup-function 'string)) |
684 | |
685 | (defmethod writer-function ((type (eql 'pathname)) &rest args) |
686 | (declare (ignore type args)) |
687 | (let ((string-writer (writer-function 'string))) |
688 | #'(lambda (path location &optional (offset 0)) |
689 | (funcall string-writer (namestring path) location offset)))) |
690 | |
691 | (defmethod reader-function ((type (eql 'pathname)) &rest args) |
692 | (declare (ignore type args)) |
693 | (let ((string-reader (reader-function 'string))) |
694 | #'(lambda (location &optional (offset 0)) |
695 | (let ((string (funcall string-reader location offset))) |
696 | (when string |
697 | (parse-namestring string)))))) |
698 | |
699 | (defmethod destroy-function ((type (eql 'pathname)) &rest args) |
700 | (declare (ignore type args)) |
701 | (destroy-function 'string)) |
702 | |
b6bf802c |
703 | (defmethod unbound-value ((type (eql 'pathname)) &rest args) |
704 | (declare (ignore type args)) |
705 | (unbound-value 'string)) |
706 | |
6baf860c |
707 | |
708 | (defmethod alien-type ((type (eql 'boolean)) &rest args) |
709 | (apply #'alien-type 'signed-byte args)) |
710 | |
711 | (defmethod size-of ((type (eql 'boolean)) &rest args) |
712 | (apply #'size-of 'signed-byte args)) |
713 | |
714 | (defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args) |
715 | (declare (ignore type args)) |
fc358945 |
716 | `(if ,boolean 1 0)) |
717 | |
6baf860c |
718 | (defmethod to-alien-function ((type (eql 'boolean)) &rest args) |
719 | (declare (ignore type args)) |
720 | #'(lambda (boolean) |
721 | (if boolean 1 0))) |
722 | |
723 | (defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args) |
724 | (declare (ignore type args)) |
725 | `(not (zerop ,boolean))) |
726 | |
727 | (defmethod from-alien-function ((type (eql 'boolean)) &rest args) |
728 | (declare (ignore type args)) |
729 | #'(lambda (boolean) |
730 | (not (zerop boolean)))) |
731 | |
732 | (defmethod writer-function ((type (eql 'boolean)) &rest args) |
733 | (declare (ignore type)) |
734 | (let ((writer (apply #'writer-function 'signed-byte args))) |
735 | #'(lambda (boolean location &optional (offset 0)) |
736 | (funcall writer (if boolean 1 0) location offset)))) |
737 | |
738 | (defmethod reader-function ((type (eql 'boolean)) &rest args) |
739 | (declare (ignore type)) |
740 | (let ((reader (apply #'reader-function 'signed-byte args))) |
741 | #'(lambda (location &optional (offset 0)) |
742 | (not (zerop (funcall reader location offset)))))) |
743 | |
744 | |
745 | (defmethod alien-type ((type (eql 'or)) &rest args) |
746 | (let ((alien-type (alien-type (first args)))) |
747 | (unless (every #'(lambda (type) |
748 | (eq alien-type (alien-type type))) |
749 | (rest args)) |
750 | (error "No common alien type specifier for union type: ~A" |
751 | (cons type args))) |
fc358945 |
752 | alien-type)) |
753 | |
6baf860c |
754 | (defmethod size-of ((type (eql 'or)) &rest args) |
755 | (declare (ignore type)) |
756 | (size-of (first args))) |
757 | |
758 | (defmethod to-alien-form (form (type (eql 'or)) &rest args) |
759 | (declare (ignore type)) |
760 | `(let ((value ,form)) |
761 | (etypecase value |
762 | ,@(mapcar |
763 | #'(lambda (type) |
764 | `(,type ,(to-alien-form 'value type))) |
765 | args)))) |
766 | |
767 | (defmethod to-alien-function ((type (eql 'or)) &rest types) |
768 | (declare (ignore type)) |
769 | (let ((functions (mapcar #'to-alien-function types))) |
770 | #'(lambda (value) |
771 | (loop |
772 | for function in functions |
773 | for type in types |
774 | when (typep value type) |
775 | do (return (funcall function value)) |
776 | finally (error "~S is not of type ~A" value `(or ,@types)))))) |
777 | |
778 | (defmethod alien-type ((type (eql 'system-area-pointer)) &rest args) |
779 | (declare (ignore type args)) |
fc358945 |
780 | 'system-area-pointer) |
781 | |
6baf860c |
782 | (defmethod size-of ((type (eql 'system-area-pointer)) &rest args) |
783 | (declare (ignore type args)) |
784 | +size-of-pointer+) |
fc358945 |
785 | |
6baf860c |
786 | (defmethod writer-function ((type (eql 'system-area-pointer)) &rest args) |
787 | (declare (ignore type args)) |
788 | #'(lambda (sap location &optional (offset 0)) |
789 | (setf (sap-ref-sap location offset) sap))) |
fc358945 |
790 | |
6baf860c |
791 | (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args) |
792 | (declare (ignore type args)) |
793 | #'(lambda (location &optional (offset 0)) |
794 | (sap-ref-sap location offset))) |
fc358945 |
795 | |
796 | |
6baf860c |
797 | (defmethod alien-type ((type (eql 'null)) &rest args) |
798 | (declare (ignore type args)) |
799 | (alien-type 'pointer)) |
fc358945 |
800 | |
6baf860c |
801 | (defmethod size-of ((type (eql 'null)) &rest args) |
802 | (declare (ignore type args)) |
803 | (size-of 'pointer)) |
804 | |
805 | (defmethod to-alien-form (null (type (eql 'null)) &rest args) |
806 | (declare (ignore null type args)) |
fc358945 |
807 | `(make-pointer 0)) |
808 | |
6baf860c |
809 | (defmethod to-alien-function ((type (eql 'null)) &rest args) |
810 | (declare (ignore type args)) |
811 | #'(lambda (null) |
812 | (declare (ignore null)) |
813 | (make-pointer 0))) |
fc358945 |
814 | |
fc358945 |
815 | |
6baf860c |
816 | (defmethod alien-type ((type (eql 'nil)) &rest args) |
817 | (declare (ignore type args)) |
3d36c5d6 |
818 | 'void) |
6baf860c |
819 | |
820 | (defmethod from-alien-function ((type (eql 'nil)) &rest args) |
821 | (declare (ignore type args)) |
822 | #'(lambda (value) |
823 | (declare (ignore value)) |
824 | (values))) |
508d13a7 |
825 | |
826 | |
827 | (defmethod alien-type ((type (eql 'copy-of)) &rest args) |
828 | (declare (ignore type)) |
829 | (alien-type (first args))) |
830 | |
831 | (defmethod size-of ((type (eql 'copy-of)) &rest args) |
832 | (declare (ignore type)) |
833 | (size-of (first args))) |
834 | |
835 | (defmethod to-alien-form (form (type (eql 'copy-of)) &rest args) |
836 | (declare (ignore type)) |
837 | (copy-to-alien-form form (first args))) |
838 | |
839 | (defmethod to-alien-function ((type (eql 'copy-of)) &rest args) |
840 | (declare (ignore type)) |
841 | (copy-to-alien-function (first args))) |
842 | |
843 | (defmethod from-alien-form (form (type (eql 'copy-of)) &rest args) |
844 | (declare (ignore type)) |
845 | (copy-from-alien-form form (first args))) |
846 | |
847 | (defmethod from-alien-function ((type (eql 'copy-of)) &rest args) |
848 | (declare (ignore type)) |
849 | (copy-from-alien-function (first args))) |
850 | |
4c795125 |
851 | (defmethod reader-function ((type (eql 'copy-of)) &rest args) |
852 | (declare (ignore type)) |
853 | (reader-function (first args))) |
854 | |
855 | (defmethod writer-function ((type (eql 'copy-of)) &rest args) |
856 | (declare (ignore type)) |
857 | (writer-function (first args))) |
ff8fa451 |
858 | |
859 | |
860 | (defmethod alien-type ((type (eql 'callback)) &rest args) |
861 | (declare (ignore type args)) |
862 | (alien-type 'pointer)) |
863 | |
864 | (defmethod size-of ((type (eql 'callback)) &rest args) |
865 | (declare (ignore type args)) |
866 | (size-of 'pointer)) |
867 | |
868 | (defmethod to-alien-form (callback (type (eql 'callback)) &rest args) |
869 | (declare (ignore type args)) |
870 | #+cmu `(callback ,callback) |
871 | #+sbcl `(sb-alien:alien-function-sap ,callback)) |
872 | |
873 | (defmethod to-alien-function ((type (eql 'callback)) &rest args) |
874 | (declare (ignore type args)) |
875 | #+cmu #'(lambda (callback) (callback callback)) |
876 | #+sbcl #'sb-alien:alien-function-sap) |
877 | |
878 | #+cmu |
879 | (defun find-callback (pointer) |
880 | (find pointer alien::*callbacks* :key #'callback-trampoline :test #'sap=)) |
881 | |
882 | (defmethod from-alien-form (pointer (type (eql 'callback)) &rest args) |
883 | (declare (ignore type args)) |
884 | #+cmu `(find-callback ,pointer) |
885 | #+sbcl `(sb-alien::%find-alien-function ,pointer)) |
886 | |
887 | (defmethod from-alien-function ((type (eql 'callback)) &rest args) |
888 | (declare (ignore type args)) |
889 | #+cmu #'find-callback |
890 | #+sbcl #'sb-alien::%find-alien-function) |
891 | |
892 | (defmethod writer-function ((type (eql 'callback)) &rest args) |
893 | (declare (ignore type args)) |
894 | (let ((writer (writer-function 'pointer)) |
895 | (to-alien (to-alien-function 'callback))) |
896 | #'(lambda (callback location &optional (offset 0)) |
897 | (funcall writer (funcall to-alien callback) location offset)))) |
898 | |
899 | (defmethod reader-function ((type (eql 'callback)) &rest args) |
900 | (declare (ignore type args)) |
901 | (let ((reader (reader-function 'pointer)) |
902 | (from-alien (from-alien-function 'callback))) |
903 | #'(lambda (location &optional (offset 0)) |
904 | (let ((pointer (funcall reader location offset))) |
905 | (unless (null-pointer-p pointer) |
906 | (funcall from-alien pointer)))))) |
907 | |
908 | (defmethod unbound-value ((type (eql 'callback)) &rest args) |
909 | (declare (ignore type args)) |
910 | (values t nil)) |