310da1d5 |
1 | ;; Common Lisp bindings for GTK+ v2.0 |
2 | ;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no> |
3 | ;; |
4 | ;; This library is free software; you can redistribute it and/or |
5 | ;; modify it under the terms of the GNU Lesser General Public |
6 | ;; License as published by the Free Software Foundation; either |
7 | ;; version 2 of the License, or (at your option) any later version. |
8 | ;; |
9 | ;; This library is distributed in the hope that it will be useful, |
10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | ;; Lesser General Public License for more details. |
13 | ;; |
14 | ;; You should have received a copy of the GNU Lesser General Public |
15 | ;; License along with this library; if not, write to the Free Software |
16 | ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
17 | |
fefc2058 |
18 | ;; $Id: ffi.lisp,v 1.15 2005-02-15 15:28:15 espen Exp $ |
310da1d5 |
19 | |
20 | (in-package "GLIB") |
21 | |
310da1d5 |
22 | |
23 | ;;;; Foreign function call interface |
24 | |
25 | (defvar *package-prefix* nil) |
26 | |
27 | (defun set-package-prefix (prefix &optional (package *package*)) |
28 | (let ((package (find-package package))) |
29 | (delete-if #'(lambda (assoc) (eq (car assoc) package)) *package-prefix*) |
30 | (push (cons package prefix) *package-prefix*)) |
31 | prefix) |
32 | |
33 | (defun package-prefix (&optional (package *package*)) |
34 | (let ((package (find-package package))) |
35 | (or |
36 | (cdr (assoc package *package-prefix*)) |
37 | (substitute #\_ #\- (string-downcase (package-name package)))))) |
38 | |
39 | (defun find-prefix-package (prefix) |
40 | (or |
41 | (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=)) |
42 | (find-package (string-upcase prefix)))) |
43 | |
44 | (defmacro use-prefix (prefix &optional (package *package*)) |
45 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
46 | (set-package-prefix ,prefix ,package))) |
47 | |
48 | |
49 | (defun default-alien-fname (lisp-name) |
1ff84b06 |
50 | (let* ((name (substitute #\_ #\- (string-downcase lisp-name))) |
51 | (stripped-name |
52 | (cond |
53 | ((and |
54 | (char= (char name 0) #\%) |
55 | (string= "_p" name :start2 (- (length name) 2))) |
56 | (subseq name 1 (- (length name) 2))) |
57 | ((char= (char name 0) #\%) |
58 | (subseq name 1)) |
59 | ((string= "_p" name :start2 (- (length name) 2)) |
60 | (subseq name 0 (- (length name) 2))) |
61 | (name))) |
62 | (prefix (package-prefix *package*))) |
310da1d5 |
63 | (if (or (not prefix) (string= prefix "")) |
1ff84b06 |
64 | stripped-name |
65 | (format nil "~A_~A" prefix stripped-name)))) |
310da1d5 |
66 | |
67 | (defun default-alien-type-name (type-name) |
68 | (let ((prefix (package-prefix *package*))) |
69 | (apply |
70 | #'concatenate |
71 | 'string |
72 | (mapcar |
73 | #'string-capitalize |
74 | (cons prefix (split-string (symbol-name type-name) #\-)))))) |
75 | |
76 | (defun default-type-name (alien-name) |
77 | (let ((parts |
78 | (mapcar |
79 | #'string-upcase |
80 | (split-string-if alien-name #'upper-case-p)))) |
81 | (intern |
82 | (concatenate-strings |
83 | (rest parts) #\-) (find-prefix-package (first parts))))) |
84 | |
85 | |
9adccb27 |
86 | (defmacro defbinding (name lambda-list return-type &rest docs/args) |
310da1d5 |
87 | (multiple-value-bind (lisp-name c-name) |
88 | (if (atom name) |
89 | (values name (default-alien-fname name)) |
90 | (values-list name)) |
91 | |
92 | (let ((supplied-lambda-list lambda-list) |
93 | (docs nil) |
94 | (args nil)) |
95 | (dolist (doc/arg docs/args) |
96 | (if (stringp doc/arg) |
97 | (push doc/arg docs) |
98 | (progn |
99 | (destructuring-bind (expr type &optional (style :in)) doc/arg |
3840beb2 |
100 | (unless (member style '(:in :out :in-out :return)) |
310da1d5 |
101 | (error "Bogus argument style ~S in ~S." style doc/arg)) |
102 | (when (and |
103 | (not supplied-lambda-list) |
3840beb2 |
104 | (namep expr) (member style '(:in :in-out :return))) |
310da1d5 |
105 | (push expr lambda-list)) |
7a6c048d |
106 | (push (list (cond |
107 | ((and (namep expr) (eq style :out)) expr) |
108 | ((namep expr) (make-symbol (string expr))) |
109 | ((gensym))) |
110 | expr (mklist type) style) args))))) |
310da1d5 |
111 | |
112 | (%defbinding |
113 | c-name lisp-name (or supplied-lambda-list (nreverse lambda-list)) |
9adccb27 |
114 | return-type (reverse docs) (reverse args))))) |
310da1d5 |
115 | |
73572c12 |
116 | #+(or cmu sbcl) |
9adccb27 |
117 | (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args) |
73572c12 |
118 | (collect ((alien-types) (alien-bindings) (alien-parameters) |
119 | (return-values) (cleanup-forms)) |
310da1d5 |
120 | (dolist (arg args) |
9adccb27 |
121 | (destructuring-bind (var expr type style) arg |
122 | (let ((declaration (alien-type type)) |
123 | (cleanup (cleanup-form var type))) |
124 | |
310da1d5 |
125 | (cond |
3840beb2 |
126 | ((member style '(:out :in-out)) |
127 | (alien-types `(* ,declaration)) |
128 | (alien-parameters `(addr ,var)) |
129 | (alien-bindings |
130 | `(,var ,declaration |
fefc2058 |
131 | ,@(cond |
132 | ((eq style :in-out) (list (to-alien-form expr type))) |
133 | ((eq declaration 'system-area-pointer) |
134 | (list '(make-pointer 0)))))) |
3840beb2 |
135 | (return-values (from-alien-form var type))) |
136 | ((eq style :return) |
137 | (alien-types declaration) |
138 | (alien-bindings |
139 | `(,var ,declaration ,(to-alien-form expr type))) |
140 | (alien-parameters var) |
141 | (return-values (from-alien-form var type))) |
142 | (cleanup |
143 | (alien-types declaration) |
144 | (alien-bindings |
145 | `(,var ,declaration ,(to-alien-form expr type))) |
146 | (alien-parameters var) |
147 | (cleanup-forms cleanup)) |
148 | (t |
149 | (alien-types declaration) |
150 | (alien-parameters (to-alien-form expr type))))))) |
310da1d5 |
151 | |
152 | (let* ((alien-name (make-symbol (string lisp-name))) |
153 | (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters)))) |
154 | `(defun ,lisp-name ,lambda-list |
155 | ,@docs |
73572c12 |
156 | #+cmu(declare (optimize (inhibit-warnings 3))) |
157 | #+sbcl(declare (muffle-conditions compiler-note)) |
310da1d5 |
158 | (with-alien ((,alien-name |
159 | (function |
9adccb27 |
160 | ,(alien-type return-type) |
310da1d5 |
161 | ,@(alien-types)) |
162 | :extern ,foreign-name) |
163 | ,@(alien-bindings)) |
9adccb27 |
164 | ,(if return-type |
165 | `(values |
166 | (unwind-protect |
167 | ,(from-alien-form alien-funcall return-type) |
168 | ,@(cleanup-forms)) |
3840beb2 |
169 | ,@(return-values)) |
310da1d5 |
170 | `(progn |
9adccb27 |
171 | (unwind-protect |
172 | ,alien-funcall |
173 | ,@(cleanup-forms)) |
3840beb2 |
174 | (values ,@(return-values))))))))) |
310da1d5 |
175 | |
176 | |
9adccb27 |
177 | ;;; Creates bindings at runtime |
310da1d5 |
178 | (defun mkbinding (name return-type &rest arg-types) |
73572c12 |
179 | #+cmu(declare (optimize (inhibit-warnings 3))) |
180 | #+sbcl(declare (muffle-conditions compiler-note)) |
9adccb27 |
181 | (let* ((ftype |
182 | `(function ,@(mapcar #'alien-type (cons return-type arg-types)))) |
310da1d5 |
183 | (alien |
73572c12 |
184 | (%heap-alien |
185 | (make-heap-alien-info |
186 | :type (parse-alien-type ftype #+sbcl nil) |
187 | :sap-form (foreign-symbol-address name)))) |
9adccb27 |
188 | (translate-arguments (mapcar #'to-alien-function arg-types)) |
189 | (translate-return-value (from-alien-function return-type)) |
190 | (cleanup-arguments (mapcar #'cleanup-function arg-types))) |
191 | |
310da1d5 |
192 | #'(lambda (&rest args) |
193 | (map-into args #'funcall translate-arguments args) |
194 | (prog1 |
9adccb27 |
195 | (funcall translate-return-value |
73572c12 |
196 | (apply #'alien-funcall alien args)) |
310da1d5 |
197 | (mapc #'funcall cleanup-arguments args))))) |
198 | |
8755b1a5 |
199 | |
200 | (defmacro defcallback (name (return-type &rest args) &body body) |
73572c12 |
201 | (let ((def-callback #+cmu'alien:def-callback |
202 | #+sbcl'sb-alien:define-alien-function)) |
203 | `(,def-callback ,name |
204 | (,(alien-type return-type) |
205 | ,@(mapcar #'(lambda (arg) |
206 | (destructuring-bind (name type) arg |
207 | `(,name ,(alien-type type)))) |
208 | args)) |
209 | ,(to-alien-form |
210 | `(let (,@(mapcar #'(lambda (arg) |
211 | (destructuring-bind (name type) arg |
212 | `(,name ,(from-alien-form name type)))) |
213 | args)) |
214 | ,@body) |
215 | return-type)))) |
216 | |
217 | #+sbcl |
218 | (defun callback (af) |
219 | (sb-alien:alien-function-sap af)) |
8755b1a5 |
220 | |
310da1d5 |
221 | |
222 | ;;;; Definitons and translations of fundamental types |
223 | |
9adccb27 |
224 | (defmacro def-type-method (name args &optional documentation) |
225 | `(progn |
226 | (defgeneric ,name (,@args type &rest args) |
227 | ,@(when documentation `((:documentation ,documentation)))) |
228 | (defmethod ,name (,@args (type symbol) &rest args) |
229 | (let ((class (find-class type nil))) |
230 | (if class |
231 | (apply #',name ,@args class args) |
232 | (multiple-value-bind (super-type expanded-p) |
233 | (type-expand-1 (cons type args)) |
234 | (if expanded-p |
235 | (,name ,@args super-type) |
236 | (call-next-method)))))) |
237 | (defmethod ,name (,@args (type cons) &rest args) |
238 | (declare (ignore args)) |
239 | (apply #',name ,@args (first type) (rest type))))) |
240 | |
310da1d5 |
241 | |
9adccb27 |
242 | (def-type-method alien-type ()) |
243 | (def-type-method size-of ()) |
244 | (def-type-method to-alien-form (form)) |
245 | (def-type-method from-alien-form (form)) |
246 | (def-type-method cleanup-form (form) |
247 | "Creates a form to clean up after the alien call has finished.") |
310da1d5 |
248 | |
9adccb27 |
249 | (def-type-method to-alien-function ()) |
250 | (def-type-method from-alien-function ()) |
251 | (def-type-method cleanup-function ()) |
310da1d5 |
252 | |
9ca5565a |
253 | (def-type-method copy-to-alien-form (form)) |
254 | (def-type-method copy-to-alien-function ()) |
255 | (def-type-method copy-from-alien-form (form)) |
256 | (def-type-method copy-from-alien-function ()) |
257 | |
9adccb27 |
258 | (def-type-method writer-function ()) |
259 | (def-type-method reader-function ()) |
260 | (def-type-method destroy-function ()) |
310da1d5 |
261 | |
12b7df04 |
262 | (def-type-method unbound-value () |
263 | "First return value is true if the type has an unbound value, second return value is the actual unbound value") |
264 | |
310da1d5 |
265 | |
8755b1a5 |
266 | ;; Sizes of fundamental C types in bytes (8 bits) |
267 | (defconstant +size-of-short+ 2) |
268 | (defconstant +size-of-int+ 4) |
269 | (defconstant +size-of-long+ 4) |
270 | (defconstant +size-of-pointer+ 4) |
271 | (defconstant +size-of-float+ 4) |
272 | (defconstant +size-of-double+ 8) |
273 | |
274 | ;; Sizes of fundamental C types in bits |
275 | (defconstant +bits-of-byte+ 8) |
276 | (defconstant +bits-of-short+ 16) |
277 | (defconstant +bits-of-int+ 32) |
278 | (defconstant +bits-of-long+ 32) |
279 | |
280 | |
9adccb27 |
281 | (deftype int () '(signed-byte #.+bits-of-int+)) |
282 | (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+)) |
283 | (deftype long () '(signed-byte #.+bits-of-long+)) |
284 | (deftype unsigned-long () '(unsigned-byte #.+bits-of-long+)) |
285 | (deftype short () '(signed-byte #.+bits-of-short+)) |
286 | (deftype unsigned-short () '(unsigned-byte #.+bits-of-short+)) |
287 | (deftype signed (&optional (size '*)) `(signed-byte ,size)) |
288 | (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size)) |
289 | (deftype char () 'base-char) |
290 | (deftype pointer () 'system-area-pointer) |
291 | (deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil)) |
292 | ;(deftype invalid () nil) |
310da1d5 |
293 | |
294 | |
9adccb27 |
295 | (defmethod to-alien-form (form (type t) &rest args) |
296 | (declare (ignore type args)) |
297 | form) |
310da1d5 |
298 | |
9adccb27 |
299 | (defmethod to-alien-function ((type t) &rest args) |
300 | (declare (ignore type args)) |
301 | #'identity) |
310da1d5 |
302 | |
9adccb27 |
303 | (defmethod from-alien-form (form (type t) &rest args) |
304 | (declare (ignore type args)) |
305 | form) |
310da1d5 |
306 | |
9adccb27 |
307 | (defmethod from-alien-function ((type t) &rest args) |
308 | (declare (ignore type args)) |
309 | #'identity) |
310 | |
311 | (defmethod cleanup-form (form (type t) &rest args) |
312 | (declare (ignore form type args)) |
313 | nil) |
310da1d5 |
314 | |
9adccb27 |
315 | (defmethod cleanup-function ((type t) &rest args) |
316 | (declare (ignore type args)) |
317 | #'identity) |
318 | |
319 | (defmethod destroy-function ((type t) &rest args) |
320 | (declare (ignore type args)) |
cdd375f3 |
321 | #'(lambda (location &optional offset) |
9adccb27 |
322 | (declare (ignore location offset)))) |
323 | |
9ca5565a |
324 | (defmethod copy-to-alien-form (form (type t) &rest args) |
325 | (apply #'to-alien-form form type args)) |
326 | |
327 | (defmethod copy-to-alien-function ((type t) &rest args) |
328 | (apply #'to-alien-function type args)) |
329 | |
330 | (defmethod copy-from-alien-form (form (type t) &rest args) |
331 | (apply #'from-alien-form form type args)) |
332 | |
333 | (defmethod copy-from-alien-function ((type t) &rest args) |
334 | (apply #'from-alien-function type args)) |
335 | |
9adccb27 |
336 | |
337 | (defmethod alien-type ((type (eql 'signed-byte)) &rest args) |
338 | (declare (ignore type)) |
339 | (destructuring-bind (&optional (size '*)) args |
340 | (ecase size |
73572c12 |
341 | (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8)) |
342 | (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short) |
343 | ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int) |
344 | (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long)))) |
9adccb27 |
345 | |
346 | (defmethod size-of ((type (eql 'signed-byte)) &rest args) |
347 | (declare (ignore type)) |
348 | (destructuring-bind (&optional (size '*)) args |
349 | (ecase size |
350 | (#.+bits-of-byte+ 1) |
351 | (#.+bits-of-short+ +size-of-short+) |
352 | ((* #.+bits-of-int+) +size-of-int+) |
353 | (#.+bits-of-long+ +size-of-long+)))) |
354 | |
12b7df04 |
355 | (defmethod unbound-value ((type t) &rest args) |
356 | (declare (ignore type args)) |
357 | nil) |
358 | |
9adccb27 |
359 | (defmethod writer-function ((type (eql 'signed-byte)) &rest args) |
360 | (declare (ignore type)) |
361 | (destructuring-bind (&optional (size '*)) args |
362 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
363 | (ecase size |
364 | (8 #'(lambda (value location &optional (offset 0)) |
365 | (setf (signed-sap-ref-8 location offset) value))) |
366 | (16 #'(lambda (value location &optional (offset 0)) |
367 | (setf (signed-sap-ref-16 location offset) value))) |
368 | (32 #'(lambda (value location &optional (offset 0)) |
369 | (setf (signed-sap-ref-32 location offset) value))) |
370 | (64 #'(lambda (value location &optional (offset 0)) |
371 | (setf (signed-sap-ref-64 location offset) value))))))) |
372 | |
373 | (defmethod reader-function ((type (eql 'signed-byte)) &rest args) |
374 | (declare (ignore type)) |
375 | (destructuring-bind (&optional (size '*)) args |
376 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
377 | (ecase size |
378 | (8 #'(lambda (sap &optional (offset 0)) |
379 | (signed-sap-ref-8 sap offset))) |
380 | (16 #'(lambda (sap &optional (offset 0)) |
381 | (signed-sap-ref-16 sap offset))) |
382 | (32 #'(lambda (sap &optional (offset 0)) |
383 | (signed-sap-ref-32 sap offset))) |
384 | (64 #'(lambda (sap &optional (offset 0)) |
385 | (signed-sap-ref-64 sap offset))))))) |
386 | |
387 | (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args) |
388 | (destructuring-bind (&optional (size '*)) args |
389 | (ecase size |
73572c12 |
390 | (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8)) |
391 | (#.+bits-of-short+ #+cmu 'c-call:unsigned-short |
392 | #+sbcl 'sb-alien:unsigned-short) |
393 | ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int |
394 | #+sbcl 'sb-alien:unsigned-int) |
395 | (#.+bits-of-long+ #+cmu 'c-call:unsigned-long |
396 | #+sbcl 'sb-alien:unsigned-long)))) |
9adccb27 |
397 | |
398 | (defmethod size-of ((type (eql 'unsigned-byte)) &rest args) |
399 | (apply #'size-of 'signed args)) |
400 | |
401 | (defmethod writer-function ((type (eql 'unsigned-byte)) &rest args) |
402 | (declare (ignore type)) |
403 | (destructuring-bind (&optional (size '*)) args |
404 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
405 | (ecase size |
406 | (8 #'(lambda (value location &optional (offset 0)) |
407 | (setf (sap-ref-8 location offset) value))) |
408 | (16 #'(lambda (value location &optional (offset 0)) |
409 | (setf (sap-ref-16 location offset) value))) |
410 | (32 #'(lambda (value location &optional (offset 0)) |
411 | (setf (sap-ref-32 location offset) value))) |
412 | (64 #'(lambda (value location &optional (offset 0)) |
413 | (setf (sap-ref-64 location offset) value))))))) |
414 | |
415 | (defmethod reader-function ((type (eql 'unsigned-byte)) &rest args) |
416 | (declare (ignore type)) |
417 | (destructuring-bind (&optional (size '*)) args |
418 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
419 | (ecase size |
420 | (8 #'(lambda (sap &optional (offset 0)) |
421 | (sap-ref-8 sap offset))) |
422 | (16 #'(lambda (sap &optional (offset 0)) |
423 | (sap-ref-16 sap offset))) |
424 | (32 #'(lambda (sap &optional (offset 0)) |
425 | (sap-ref-32 sap offset))) |
426 | (64 #'(lambda (sap &optional (offset 0)) |
427 | (sap-ref-64 sap offset))))))) |
428 | |
429 | |
430 | (defmethod alien-type ((type (eql 'integer)) &rest args) |
431 | (declare (ignore type args)) |
432 | (alien-type 'signed-byte)) |
310da1d5 |
433 | |
9adccb27 |
434 | (defmethod size-of ((type (eql 'integer)) &rest args) |
435 | (declare (ignore type args)) |
436 | (size-of 'signed-byte)) |
310da1d5 |
437 | |
78778e5a |
438 | (defmethod writer-function ((type (eql 'integer)) &rest args) |
439 | (declare (ignore type args)) |
440 | (writer-function 'signed-byte)) |
441 | |
442 | (defmethod reader-function ((type (eql 'integer)) &rest args) |
443 | (declare (ignore type args)) |
444 | (reader-function 'signed-byte)) |
445 | |
310da1d5 |
446 | |
9adccb27 |
447 | (defmethod alien-type ((type (eql 'fixnum)) &rest args) |
448 | (declare (ignore type args)) |
449 | (alien-type 'signed-byte)) |
310da1d5 |
450 | |
9adccb27 |
451 | (defmethod size-of ((type (eql 'fixnum)) &rest args) |
452 | (declare (ignore type args)) |
453 | (size-of 'signed-byte)) |
310da1d5 |
454 | |
455 | |
9adccb27 |
456 | (defmethod alien-type ((type (eql 'single-float)) &rest args) |
457 | (declare (ignore type args)) |
73572c12 |
458 | #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float) |
310da1d5 |
459 | |
9adccb27 |
460 | (defmethod size-of ((type (eql 'single-float)) &rest args) |
461 | (declare (ignore type args)) |
310da1d5 |
462 | +size-of-float+) |
463 | |
9adccb27 |
464 | (defmethod writer-function ((type (eql 'single-float)) &rest args) |
465 | (declare (ignore type args)) |
466 | #'(lambda (value location &optional (offset 0)) |
8755b1a5 |
467 | (setf (sap-ref-single location offset) (coerce value 'single-float)))) |
310da1d5 |
468 | |
9adccb27 |
469 | (defmethod reader-function ((type (eql 'single-float)) &rest args) |
470 | (declare (ignore type args)) |
471 | #'(lambda (sap &optional (offset 0)) |
472 | (sap-ref-single sap offset))) |
310da1d5 |
473 | |
474 | |
9adccb27 |
475 | (defmethod alien-type ((type (eql 'double-float)) &rest args) |
476 | (declare (ignore type args)) |
73572c12 |
477 | #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float) |
310da1d5 |
478 | |
9adccb27 |
479 | (defmethod size-of ((type (eql 'double-float)) &rest args) |
480 | (declare (ignore type args)) |
3d285e35 |
481 | +size-of-double+) |
310da1d5 |
482 | |
9adccb27 |
483 | (defmethod writer-function ((type (eql 'double-float)) &rest args) |
484 | (declare (ignore type args)) |
485 | #'(lambda (value location &optional (offset 0)) |
486 | (setf (sap-ref-double location offset) (coerce value 'double-float)))) |
310da1d5 |
487 | |
9adccb27 |
488 | (defmethod reader-function ((type (eql 'double-float)) &rest args) |
489 | (declare (ignore type args)) |
490 | #'(lambda (sap &optional (offset 0)) |
491 | (sap-ref-double sap offset))) |
310da1d5 |
492 | |
493 | |
9adccb27 |
494 | (defmethod alien-type ((type (eql 'base-char)) &rest args) |
495 | (declare (ignore type args)) |
73572c12 |
496 | #+cmu 'c-call:char #+sbcl 'sb-alien:char) |
310da1d5 |
497 | |
9adccb27 |
498 | (defmethod size-of ((type (eql 'base-char)) &rest args) |
499 | (declare (ignore type args)) |
310da1d5 |
500 | 1) |
501 | |
9adccb27 |
502 | (defmethod writer-function ((type (eql 'base-char)) &rest args) |
503 | (declare (ignore type args)) |
504 | #'(lambda (char location &optional (offset 0)) |
505 | (setf (sap-ref-8 location offset) (char-code char)))) |
310da1d5 |
506 | |
9adccb27 |
507 | (defmethod reader-function ((type (eql 'base-char)) &rest args) |
508 | (declare (ignore type args)) |
509 | #'(lambda (location &optional (offset 0)) |
510 | (code-char (sap-ref-8 location offset)))) |
310da1d5 |
511 | |
512 | |
9adccb27 |
513 | (defmethod alien-type ((type (eql 'string)) &rest args) |
514 | (declare (ignore type args)) |
515 | (alien-type 'pointer)) |
310da1d5 |
516 | |
9adccb27 |
517 | (defmethod size-of ((type (eql 'string)) &rest args) |
518 | (declare (ignore type args)) |
519 | (size-of 'pointer)) |
310da1d5 |
520 | |
9adccb27 |
521 | (defmethod to-alien-form (string (type (eql 'string)) &rest args) |
522 | (declare (ignore type args)) |
310da1d5 |
523 | `(let ((string ,string)) |
524 | ;; Always copy strings to prevent seg fault due to GC |
525 | (copy-memory |
73572c12 |
526 | (vector-sap (coerce string 'simple-base-string)) |
310da1d5 |
527 | (1+ (length string))))) |
310da1d5 |
528 | |
9adccb27 |
529 | (defmethod to-alien-function ((type (eql 'string)) &rest args) |
530 | (declare (ignore type args)) |
531 | #'(lambda (string) |
532 | (copy-memory |
73572c12 |
533 | (vector-sap (coerce string 'simple-base-string)) |
9adccb27 |
534 | (1+ (length string))))) |
535 | |
536 | (defmethod from-alien-form (string (type (eql 'string)) &rest args) |
537 | (declare (ignore type args)) |
538 | `(let ((string ,string)) |
539 | (unless (null-pointer-p string) |
9ca5565a |
540 | (prog1 |
73572c12 |
541 | (%naturalize-c-string string) |
9ca5565a |
542 | (deallocate-memory string))))) |
310da1d5 |
543 | |
9adccb27 |
544 | (defmethod from-alien-function ((type (eql 'string)) &rest args) |
545 | (declare (ignore type args)) |
546 | #'(lambda (string) |
547 | (unless (null-pointer-p string) |
9ca5565a |
548 | (prog1 |
73572c12 |
549 | (%naturalize-c-string string) |
9ca5565a |
550 | (deallocate-memory string))))) |
310da1d5 |
551 | |
9adccb27 |
552 | (defmethod cleanup-form (string (type (eql 'string)) &rest args) |
553 | (declare (ignore type args)) |
554 | `(let ((string ,string)) |
555 | (unless (null-pointer-p string) |
556 | (deallocate-memory string)))) |
557 | |
558 | (defmethod cleanup-function ((type (eql 'string)) &rest args) |
8755b1a5 |
559 | (declare (ignore args)) |
9adccb27 |
560 | #'(lambda (string) |
561 | (unless (null-pointer-p string) |
562 | (deallocate-memory string)))) |
563 | |
9ca5565a |
564 | (defmethod copy-from-alien-form (string (type (eql 'string)) &rest args) |
565 | (declare (ignore type args)) |
566 | `(let ((string ,string)) |
567 | (unless (null-pointer-p string) |
73572c12 |
568 | (%naturalize-c-string string)))) |
569 | |
9ca5565a |
570 | |
571 | (defmethod copy-from-alien-function ((type (eql 'string)) &rest args) |
572 | (declare (ignore type args)) |
573 | #'(lambda (string) |
574 | (unless (null-pointer-p string) |
73572c12 |
575 | (%naturalize-c-string string)))) |
9ca5565a |
576 | |
9adccb27 |
577 | (defmethod writer-function ((type (eql 'string)) &rest args) |
578 | (declare (ignore type args)) |
579 | #'(lambda (string location &optional (offset 0)) |
580 | (assert (null-pointer-p (sap-ref-sap location offset))) |
581 | (setf (sap-ref-sap location offset) |
582 | (copy-memory |
73572c12 |
583 | (vector-sap (coerce string 'simple-base-string)) |
9adccb27 |
584 | (1+ (length string)))))) |
585 | |
586 | (defmethod reader-function ((type (eql 'string)) &rest args) |
587 | (declare (ignore type args)) |
588 | #'(lambda (location &optional (offset 0)) |
589 | (unless (null-pointer-p (sap-ref-sap location offset)) |
73572c12 |
590 | (%naturalize-c-string (sap-ref-sap location offset))))) |
9adccb27 |
591 | |
592 | (defmethod destroy-function ((type (eql 'string)) &rest args) |
593 | (declare (ignore type args)) |
594 | #'(lambda (location &optional (offset 0)) |
595 | (unless (null-pointer-p (sap-ref-sap location offset)) |
596 | (deallocate-memory (sap-ref-sap location offset)) |
597 | (setf (sap-ref-sap location offset) (make-pointer 0))))) |
598 | |
12b7df04 |
599 | (defmethod unbound-value ((type (eql 'string)) &rest args) |
600 | (declare (ignore type args)) |
601 | (values t nil)) |
9adccb27 |
602 | |
603 | (defmethod alien-type ((type (eql 'pathname)) &rest args) |
604 | (declare (ignore type args)) |
605 | (alien-type 'string)) |
606 | |
607 | (defmethod size-of ((type (eql 'pathname)) &rest args) |
608 | (declare (ignore type args)) |
609 | (size-of 'string)) |
310da1d5 |
610 | |
9adccb27 |
611 | (defmethod to-alien-form (path (type (eql 'pathname)) &rest args) |
612 | (declare (ignore type args)) |
613 | (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string)) |
614 | |
615 | (defmethod to-alien-function ((type (eql 'pathname)) &rest args) |
616 | (declare (ignore type args)) |
617 | (let ((string-function (to-alien-function 'string))) |
618 | #'(lambda (path) |
619 | (funcall string-function (namestring path))))) |
620 | |
621 | (defmethod from-alien-form (string (type (eql 'pathname)) &rest args) |
622 | (declare (ignore type args)) |
623 | `(parse-namestring ,(from-alien-form string 'string))) |
624 | |
625 | (defmethod from-alien-function ((type (eql 'pathname)) &rest args) |
626 | (declare (ignore type args)) |
627 | (let ((string-function (from-alien-function 'string))) |
628 | #'(lambda (string) |
629 | (parse-namestring (funcall string-function string))))) |
630 | |
631 | (defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args) |
632 | (declare (ignore type args)) |
633 | (cleanup-form string 'string)) |
634 | |
635 | (defmethod cleanup-function ((type (eql 'pathnanme)) &rest args) |
636 | (declare (ignore type args)) |
637 | (cleanup-function 'string)) |
638 | |
639 | (defmethod writer-function ((type (eql 'pathname)) &rest args) |
640 | (declare (ignore type args)) |
641 | (let ((string-writer (writer-function 'string))) |
642 | #'(lambda (path location &optional (offset 0)) |
643 | (funcall string-writer (namestring path) location offset)))) |
644 | |
645 | (defmethod reader-function ((type (eql 'pathname)) &rest args) |
646 | (declare (ignore type args)) |
647 | (let ((string-reader (reader-function 'string))) |
648 | #'(lambda (location &optional (offset 0)) |
649 | (let ((string (funcall string-reader location offset))) |
650 | (when string |
651 | (parse-namestring string)))))) |
652 | |
653 | (defmethod destroy-function ((type (eql 'pathname)) &rest args) |
654 | (declare (ignore type args)) |
655 | (destroy-function 'string)) |
656 | |
12b7df04 |
657 | (defmethod unbound-value ((type (eql 'pathname)) &rest args) |
658 | (declare (ignore type args)) |
659 | (unbound-value 'string)) |
660 | |
9adccb27 |
661 | |
662 | (defmethod alien-type ((type (eql 'boolean)) &rest args) |
663 | (apply #'alien-type 'signed-byte args)) |
664 | |
665 | (defmethod size-of ((type (eql 'boolean)) &rest args) |
666 | (apply #'size-of 'signed-byte args)) |
667 | |
668 | (defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args) |
669 | (declare (ignore type args)) |
310da1d5 |
670 | `(if ,boolean 1 0)) |
671 | |
9adccb27 |
672 | (defmethod to-alien-function ((type (eql 'boolean)) &rest args) |
673 | (declare (ignore type args)) |
674 | #'(lambda (boolean) |
675 | (if boolean 1 0))) |
676 | |
677 | (defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args) |
678 | (declare (ignore type args)) |
679 | `(not (zerop ,boolean))) |
680 | |
681 | (defmethod from-alien-function ((type (eql 'boolean)) &rest args) |
682 | (declare (ignore type args)) |
683 | #'(lambda (boolean) |
684 | (not (zerop boolean)))) |
685 | |
686 | (defmethod writer-function ((type (eql 'boolean)) &rest args) |
687 | (declare (ignore type)) |
688 | (let ((writer (apply #'writer-function 'signed-byte args))) |
689 | #'(lambda (boolean location &optional (offset 0)) |
690 | (funcall writer (if boolean 1 0) location offset)))) |
691 | |
692 | (defmethod reader-function ((type (eql 'boolean)) &rest args) |
693 | (declare (ignore type)) |
694 | (let ((reader (apply #'reader-function 'signed-byte args))) |
695 | #'(lambda (location &optional (offset 0)) |
696 | (not (zerop (funcall reader location offset)))))) |
697 | |
698 | |
699 | (defmethod alien-type ((type (eql 'or)) &rest args) |
700 | (let ((alien-type (alien-type (first args)))) |
701 | (unless (every #'(lambda (type) |
702 | (eq alien-type (alien-type type))) |
703 | (rest args)) |
704 | (error "No common alien type specifier for union type: ~A" |
705 | (cons type args))) |
310da1d5 |
706 | alien-type)) |
707 | |
9adccb27 |
708 | (defmethod size-of ((type (eql 'or)) &rest args) |
709 | (declare (ignore type)) |
710 | (size-of (first args))) |
711 | |
712 | (defmethod to-alien-form (form (type (eql 'or)) &rest args) |
713 | (declare (ignore type)) |
714 | `(let ((value ,form)) |
715 | (etypecase value |
716 | ,@(mapcar |
717 | #'(lambda (type) |
718 | `(,type ,(to-alien-form 'value type))) |
719 | args)))) |
720 | |
721 | (defmethod to-alien-function ((type (eql 'or)) &rest types) |
722 | (declare (ignore type)) |
723 | (let ((functions (mapcar #'to-alien-function types))) |
724 | #'(lambda (value) |
725 | (loop |
726 | for function in functions |
727 | for type in types |
728 | when (typep value type) |
729 | do (return (funcall function value)) |
730 | finally (error "~S is not of type ~A" value `(or ,@types)))))) |
731 | |
732 | (defmethod alien-type ((type (eql 'system-area-pointer)) &rest args) |
733 | (declare (ignore type args)) |
310da1d5 |
734 | 'system-area-pointer) |
735 | |
9adccb27 |
736 | (defmethod size-of ((type (eql 'system-area-pointer)) &rest args) |
737 | (declare (ignore type args)) |
738 | +size-of-pointer+) |
310da1d5 |
739 | |
9adccb27 |
740 | (defmethod writer-function ((type (eql 'system-area-pointer)) &rest args) |
741 | (declare (ignore type args)) |
742 | #'(lambda (sap location &optional (offset 0)) |
743 | (setf (sap-ref-sap location offset) sap))) |
310da1d5 |
744 | |
9adccb27 |
745 | (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args) |
746 | (declare (ignore type args)) |
747 | #'(lambda (location &optional (offset 0)) |
748 | (sap-ref-sap location offset))) |
310da1d5 |
749 | |
750 | |
9adccb27 |
751 | (defmethod alien-type ((type (eql 'null)) &rest args) |
752 | (declare (ignore type args)) |
753 | (alien-type 'pointer)) |
310da1d5 |
754 | |
9adccb27 |
755 | (defmethod size-of ((type (eql 'null)) &rest args) |
756 | (declare (ignore type args)) |
757 | (size-of 'pointer)) |
758 | |
759 | (defmethod to-alien-form (null (type (eql 'null)) &rest args) |
760 | (declare (ignore null type args)) |
310da1d5 |
761 | `(make-pointer 0)) |
762 | |
9adccb27 |
763 | (defmethod to-alien-function ((type (eql 'null)) &rest args) |
764 | (declare (ignore type args)) |
765 | #'(lambda (null) |
766 | (declare (ignore null)) |
767 | (make-pointer 0))) |
310da1d5 |
768 | |
310da1d5 |
769 | |
9adccb27 |
770 | (defmethod alien-type ((type (eql 'nil)) &rest args) |
771 | (declare (ignore type args)) |
73572c12 |
772 | 'void) |
9adccb27 |
773 | |
774 | (defmethod from-alien-function ((type (eql 'nil)) &rest args) |
775 | (declare (ignore type args)) |
776 | #'(lambda (value) |
777 | (declare (ignore value)) |
778 | (values))) |
9ca5565a |
779 | |
780 | |
781 | (defmethod alien-type ((type (eql 'copy-of)) &rest args) |
782 | (declare (ignore type)) |
783 | (alien-type (first args))) |
784 | |
785 | (defmethod size-of ((type (eql 'copy-of)) &rest args) |
786 | (declare (ignore type)) |
787 | (size-of (first args))) |
788 | |
789 | (defmethod to-alien-form (form (type (eql 'copy-of)) &rest args) |
790 | (declare (ignore type)) |
791 | (copy-to-alien-form form (first args))) |
792 | |
793 | (defmethod to-alien-function ((type (eql 'copy-of)) &rest args) |
794 | (declare (ignore type)) |
795 | (copy-to-alien-function (first args))) |
796 | |
797 | (defmethod from-alien-form (form (type (eql 'copy-of)) &rest args) |
798 | (declare (ignore type)) |
799 | (copy-from-alien-form form (first args))) |
800 | |
801 | (defmethod from-alien-function ((type (eql 'copy-of)) &rest args) |
802 | (declare (ignore type)) |
803 | (copy-from-alien-function (first args))) |
804 | |
cdd375f3 |
805 | (defmethod reader-function ((type (eql 'copy-of)) &rest args) |
806 | (declare (ignore type)) |
807 | (reader-function (first args))) |
808 | |
809 | (defmethod writer-function ((type (eql 'copy-of)) &rest args) |
810 | (declare (ignore type)) |
811 | (writer-function (first args))) |