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 | |
9adccb27 |
18 | ;; $Id: ffi.lisp,v 1.2 2004-11-06 21:39:58 espen Exp $ |
310da1d5 |
19 | |
20 | (in-package "GLIB") |
21 | |
310da1d5 |
22 | ;;;; |
23 | |
9adccb27 |
24 | ;; Sizes of fundamental C types in bytes (8 bits) |
310da1d5 |
25 | (defconstant +size-of-short+ 2) |
26 | (defconstant +size-of-int+ 4) |
27 | (defconstant +size-of-long+ 4) |
9adccb27 |
28 | (defconstant +size-of-pointer+ 4) |
310da1d5 |
29 | (defconstant +size-of-float+ 4) |
30 | (defconstant +size-of-double+ 8) |
31 | |
9adccb27 |
32 | ;; Sizes of fundamental C types in bits |
33 | (defconstant +bits-of-byte+ 8) |
34 | (defconstant +bits-of-short+ 16) |
35 | (defconstant +bits-of-int+ 32) |
36 | (defconstant +bits-of-long+ 32) |
37 | |
38 | |
310da1d5 |
39 | |
40 | |
41 | ;;;; Foreign function call interface |
42 | |
43 | (defvar *package-prefix* nil) |
44 | |
45 | (defun set-package-prefix (prefix &optional (package *package*)) |
46 | (let ((package (find-package package))) |
47 | (delete-if #'(lambda (assoc) (eq (car assoc) package)) *package-prefix*) |
48 | (push (cons package prefix) *package-prefix*)) |
49 | prefix) |
50 | |
51 | (defun package-prefix (&optional (package *package*)) |
52 | (let ((package (find-package package))) |
53 | (or |
54 | (cdr (assoc package *package-prefix*)) |
55 | (substitute #\_ #\- (string-downcase (package-name package)))))) |
56 | |
57 | (defun find-prefix-package (prefix) |
58 | (or |
59 | (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=)) |
60 | (find-package (string-upcase prefix)))) |
61 | |
62 | (defmacro use-prefix (prefix &optional (package *package*)) |
63 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
64 | (set-package-prefix ,prefix ,package))) |
65 | |
66 | |
67 | (defun default-alien-fname (lisp-name) |
68 | (let* ((lisp-name-string |
69 | (if (char= (char (the simple-string (string lisp-name)) 0) #\%) |
70 | (subseq (the simple-string (string lisp-name)) 1) |
71 | (string lisp-name))) |
72 | (prefix (package-prefix *package*)) |
73 | (name (substitute #\_ #\- (string-downcase lisp-name-string)))) |
74 | (if (or (not prefix) (string= prefix "")) |
75 | name |
76 | (format nil "~A_~A" prefix name)))) |
77 | |
78 | (defun default-alien-type-name (type-name) |
79 | (let ((prefix (package-prefix *package*))) |
80 | (apply |
81 | #'concatenate |
82 | 'string |
83 | (mapcar |
84 | #'string-capitalize |
85 | (cons prefix (split-string (symbol-name type-name) #\-)))))) |
86 | |
87 | (defun default-type-name (alien-name) |
88 | (let ((parts |
89 | (mapcar |
90 | #'string-upcase |
91 | (split-string-if alien-name #'upper-case-p)))) |
92 | (intern |
93 | (concatenate-strings |
94 | (rest parts) #\-) (find-prefix-package (first parts))))) |
95 | |
96 | |
9adccb27 |
97 | (defmacro defbinding (name lambda-list return-type &rest docs/args) |
310da1d5 |
98 | (multiple-value-bind (lisp-name c-name) |
99 | (if (atom name) |
100 | (values name (default-alien-fname name)) |
101 | (values-list name)) |
102 | |
103 | (let ((supplied-lambda-list lambda-list) |
104 | (docs nil) |
105 | (args nil)) |
106 | (dolist (doc/arg docs/args) |
107 | (if (stringp doc/arg) |
108 | (push doc/arg docs) |
109 | (progn |
110 | (destructuring-bind (expr type &optional (style :in)) doc/arg |
111 | (unless (member style '(:in :out :in-out)) |
112 | (error "Bogus argument style ~S in ~S." style doc/arg)) |
113 | (when (and |
114 | (not supplied-lambda-list) |
115 | (namep expr) (member style '(:in :in-out))) |
116 | (push expr lambda-list)) |
117 | (push |
9adccb27 |
118 | (list (if (namep expr) |
119 | (make-symbol (string expr)) |
120 | (gensym)) |
121 | expr (mklist type) style) args))))) |
310da1d5 |
122 | |
123 | (%defbinding |
124 | c-name lisp-name (or supplied-lambda-list (nreverse lambda-list)) |
9adccb27 |
125 | return-type (reverse docs) (reverse args))))) |
310da1d5 |
126 | |
127 | #+cmu |
9adccb27 |
128 | (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args) |
129 | (ext:collect ((alien-types) (alien-bindings) (alien-parameters) |
130 | (alien-values) (cleanup-forms)) |
310da1d5 |
131 | (dolist (arg args) |
9adccb27 |
132 | (destructuring-bind (var expr type style) arg |
133 | (let ((declaration (alien-type type)) |
134 | (cleanup (cleanup-form var type))) |
135 | |
310da1d5 |
136 | (cond |
137 | ((member style '(:out :in-out)) |
138 | (alien-types `(* ,declaration)) |
139 | (alien-parameters `(addr ,var)) |
140 | (alien-bindings |
141 | `(,var ,declaration |
142 | ,@(when (eq style :in-out) |
9adccb27 |
143 | (list (to-alien-form expr type))))) |
144 | (alien-values (from-alien-form var type))) |
145 | (cleanup |
310da1d5 |
146 | (alien-types declaration) |
147 | (alien-bindings |
9adccb27 |
148 | `(,var ,declaration ,(to-alien-form expr type))) |
310da1d5 |
149 | (alien-parameters var) |
9adccb27 |
150 | (cleanup-forms cleanup)) |
310da1d5 |
151 | (t |
152 | (alien-types declaration) |
9adccb27 |
153 | (alien-parameters (to-alien-form expr type))))))) |
310da1d5 |
154 | |
155 | (let* ((alien-name (make-symbol (string lisp-name))) |
156 | (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters)))) |
157 | `(defun ,lisp-name ,lambda-list |
158 | ,@docs |
159 | (declare (optimize (ext:inhibit-warnings 3))) |
160 | (with-alien ((,alien-name |
161 | (function |
9adccb27 |
162 | ,(alien-type return-type) |
310da1d5 |
163 | ,@(alien-types)) |
164 | :extern ,foreign-name) |
165 | ,@(alien-bindings)) |
9adccb27 |
166 | ,(if return-type |
167 | `(values |
168 | (unwind-protect |
169 | ,(from-alien-form alien-funcall return-type) |
170 | ,@(cleanup-forms)) |
171 | ,@(alien-values)) |
310da1d5 |
172 | `(progn |
9adccb27 |
173 | (unwind-protect |
174 | ,alien-funcall |
175 | ,@(cleanup-forms)) |
176 | (values ,@(alien-values))))))))) |
310da1d5 |
177 | |
178 | |
9adccb27 |
179 | ;;; Creates bindings at runtime |
310da1d5 |
180 | (defun mkbinding (name return-type &rest arg-types) |
9adccb27 |
181 | (declare (optimize (ext:inhibit-warnings 3))) |
182 | (let* ((ftype |
183 | `(function ,@(mapcar #'alien-type (cons return-type arg-types)))) |
310da1d5 |
184 | (alien |
185 | (alien::%heap-alien |
186 | (alien::make-heap-alien-info |
187 | :type (alien::parse-alien-type ftype) |
188 | :sap-form (system:foreign-symbol-address name :flavor :code)))) |
9adccb27 |
189 | (translate-arguments (mapcar #'to-alien-function arg-types)) |
190 | (translate-return-value (from-alien-function return-type)) |
191 | (cleanup-arguments (mapcar #'cleanup-function arg-types))) |
192 | |
310da1d5 |
193 | #'(lambda (&rest args) |
194 | (map-into args #'funcall translate-arguments args) |
195 | (prog1 |
9adccb27 |
196 | (funcall translate-return-value |
197 | (apply #'alien:alien-funcall alien args)) |
310da1d5 |
198 | (mapc #'funcall cleanup-arguments args))))) |
199 | |
310da1d5 |
200 | |
201 | |
202 | ;;;; Definitons and translations of fundamental types |
203 | |
9adccb27 |
204 | (defmacro def-type-method (name args &optional documentation) |
205 | `(progn |
206 | (defgeneric ,name (,@args type &rest args) |
207 | ,@(when documentation `((:documentation ,documentation)))) |
208 | (defmethod ,name (,@args (type symbol) &rest args) |
209 | (let ((class (find-class type nil))) |
210 | (if class |
211 | (apply #',name ,@args class args) |
212 | (multiple-value-bind (super-type expanded-p) |
213 | (type-expand-1 (cons type args)) |
214 | (if expanded-p |
215 | (,name ,@args super-type) |
216 | (call-next-method)))))) |
217 | (defmethod ,name (,@args (type cons) &rest args) |
218 | (declare (ignore args)) |
219 | (apply #',name ,@args (first type) (rest type))))) |
220 | |
310da1d5 |
221 | |
9adccb27 |
222 | (def-type-method alien-type ()) |
223 | (def-type-method size-of ()) |
224 | (def-type-method to-alien-form (form)) |
225 | (def-type-method from-alien-form (form)) |
226 | (def-type-method cleanup-form (form) |
227 | "Creates a form to clean up after the alien call has finished.") |
310da1d5 |
228 | |
9adccb27 |
229 | (def-type-method to-alien-function ()) |
230 | (def-type-method from-alien-function ()) |
231 | (def-type-method cleanup-function ()) |
310da1d5 |
232 | |
9adccb27 |
233 | (def-type-method writer-function ()) |
234 | (def-type-method reader-function ()) |
235 | (def-type-method destroy-function ()) |
310da1d5 |
236 | |
310da1d5 |
237 | |
9adccb27 |
238 | (deftype int () '(signed-byte #.+bits-of-int+)) |
239 | (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+)) |
240 | (deftype long () '(signed-byte #.+bits-of-long+)) |
241 | (deftype unsigned-long () '(unsigned-byte #.+bits-of-long+)) |
242 | (deftype short () '(signed-byte #.+bits-of-short+)) |
243 | (deftype unsigned-short () '(unsigned-byte #.+bits-of-short+)) |
244 | (deftype signed (&optional (size '*)) `(signed-byte ,size)) |
245 | (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size)) |
246 | (deftype char () 'base-char) |
247 | (deftype pointer () 'system-area-pointer) |
248 | (deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil)) |
249 | ;(deftype invalid () nil) |
310da1d5 |
250 | |
251 | |
9adccb27 |
252 | (defmethod to-alien-form (form (type t) &rest args) |
253 | (declare (ignore type args)) |
254 | form) |
310da1d5 |
255 | |
9adccb27 |
256 | (defmethod to-alien-function ((type t) &rest args) |
257 | (declare (ignore type args)) |
258 | #'identity) |
310da1d5 |
259 | |
9adccb27 |
260 | (defmethod from-alien-form (form (type t) &rest args) |
261 | (declare (ignore type args)) |
262 | form) |
310da1d5 |
263 | |
9adccb27 |
264 | (defmethod from-alien-function ((type t) &rest args) |
265 | (declare (ignore type args)) |
266 | #'identity) |
267 | |
268 | (defmethod cleanup-form (form (type t) &rest args) |
269 | (declare (ignore form type args)) |
270 | nil) |
310da1d5 |
271 | |
9adccb27 |
272 | (defmethod cleanup-function ((type t) &rest args) |
273 | (declare (ignore type args)) |
274 | #'identity) |
275 | |
276 | (defmethod destroy-function ((type t) &rest args) |
277 | (declare (ignore type args)) |
278 | #'(lambda (location offset) |
279 | (declare (ignore location offset)))) |
280 | |
281 | |
282 | (defmethod alien-type ((type (eql 'signed-byte)) &rest args) |
283 | (declare (ignore type)) |
284 | (destructuring-bind (&optional (size '*)) args |
285 | (ecase size |
286 | (#.+bits-of-byte+ '(signed-byte 8)) |
287 | (#.+bits-of-short+ 'c-call:short) |
288 | ((* #.+bits-of-int+) 'c-call:int) |
289 | (#.+bits-of-long+ 'c-call:long)))) |
290 | |
291 | (defmethod size-of ((type (eql 'signed-byte)) &rest args) |
292 | (declare (ignore type)) |
293 | (destructuring-bind (&optional (size '*)) args |
294 | (ecase size |
295 | (#.+bits-of-byte+ 1) |
296 | (#.+bits-of-short+ +size-of-short+) |
297 | ((* #.+bits-of-int+) +size-of-int+) |
298 | (#.+bits-of-long+ +size-of-long+)))) |
299 | |
300 | (defmethod writer-function ((type (eql 'signed-byte)) &rest args) |
301 | (declare (ignore type)) |
302 | (destructuring-bind (&optional (size '*)) args |
303 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
304 | (ecase size |
305 | (8 #'(lambda (value location &optional (offset 0)) |
306 | (setf (signed-sap-ref-8 location offset) value))) |
307 | (16 #'(lambda (value location &optional (offset 0)) |
308 | (setf (signed-sap-ref-16 location offset) value))) |
309 | (32 #'(lambda (value location &optional (offset 0)) |
310 | (setf (signed-sap-ref-32 location offset) value))) |
311 | (64 #'(lambda (value location &optional (offset 0)) |
312 | (setf (signed-sap-ref-64 location offset) value))))))) |
313 | |
314 | (defmethod reader-function ((type (eql 'signed-byte)) &rest args) |
315 | (declare (ignore type)) |
316 | (destructuring-bind (&optional (size '*)) args |
317 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
318 | (ecase size |
319 | (8 #'(lambda (sap &optional (offset 0)) |
320 | (signed-sap-ref-8 sap offset))) |
321 | (16 #'(lambda (sap &optional (offset 0)) |
322 | (signed-sap-ref-16 sap offset))) |
323 | (32 #'(lambda (sap &optional (offset 0)) |
324 | (signed-sap-ref-32 sap offset))) |
325 | (64 #'(lambda (sap &optional (offset 0)) |
326 | (signed-sap-ref-64 sap offset))))))) |
327 | |
328 | (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args) |
329 | (destructuring-bind (&optional (size '*)) args |
330 | (ecase size |
331 | (#.+bits-of-byte+ '(unsigned-byte 8)) |
332 | (#.+bits-of-short+ 'c-call:unsigned-short) |
333 | ((* #.+bits-of-int+) 'c-call:unsigned-int) |
334 | (#.+bits-of-long+ 'c-call:unsigned-long)))) |
335 | |
336 | (defmethod size-of ((type (eql 'unsigned-byte)) &rest args) |
337 | (apply #'size-of 'signed args)) |
338 | |
339 | (defmethod writer-function ((type (eql 'unsigned-byte)) &rest args) |
340 | (declare (ignore type)) |
341 | (destructuring-bind (&optional (size '*)) args |
342 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
343 | (ecase size |
344 | (8 #'(lambda (value location &optional (offset 0)) |
345 | (setf (sap-ref-8 location offset) value))) |
346 | (16 #'(lambda (value location &optional (offset 0)) |
347 | (setf (sap-ref-16 location offset) value))) |
348 | (32 #'(lambda (value location &optional (offset 0)) |
349 | (setf (sap-ref-32 location offset) value))) |
350 | (64 #'(lambda (value location &optional (offset 0)) |
351 | (setf (sap-ref-64 location offset) value))))))) |
352 | |
353 | (defmethod reader-function ((type (eql 'unsigned-byte)) &rest args) |
354 | (declare (ignore type)) |
355 | (destructuring-bind (&optional (size '*)) args |
356 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
357 | (ecase size |
358 | (8 #'(lambda (sap &optional (offset 0)) |
359 | (sap-ref-8 sap offset))) |
360 | (16 #'(lambda (sap &optional (offset 0)) |
361 | (sap-ref-16 sap offset))) |
362 | (32 #'(lambda (sap &optional (offset 0)) |
363 | (sap-ref-32 sap offset))) |
364 | (64 #'(lambda (sap &optional (offset 0)) |
365 | (sap-ref-64 sap offset))))))) |
366 | |
367 | |
368 | (defmethod alien-type ((type (eql 'integer)) &rest args) |
369 | (declare (ignore type args)) |
370 | (alien-type 'signed-byte)) |
310da1d5 |
371 | |
9adccb27 |
372 | (defmethod size-of ((type (eql 'integer)) &rest args) |
373 | (declare (ignore type args)) |
374 | (size-of 'signed-byte)) |
310da1d5 |
375 | |
310da1d5 |
376 | |
9adccb27 |
377 | (defmethod alien-type ((type (eql 'fixnum)) &rest args) |
378 | (declare (ignore type args)) |
379 | (alien-type 'signed-byte)) |
310da1d5 |
380 | |
9adccb27 |
381 | (defmethod size-of ((type (eql 'fixnum)) &rest args) |
382 | (declare (ignore type args)) |
383 | (size-of 'signed-byte)) |
310da1d5 |
384 | |
385 | |
9adccb27 |
386 | (defmethod alien-type ((type (eql 'single-float)) &rest args) |
387 | (declare (ignore type args)) |
388 | 'alien:single-float) |
310da1d5 |
389 | |
9adccb27 |
390 | (defmethod size-of ((type (eql 'single-float)) &rest args) |
391 | (declare (ignore type args)) |
310da1d5 |
392 | +size-of-float+) |
393 | |
9adccb27 |
394 | (defmethod writer-function ((type (eql 'single-float)) &rest args) |
395 | (declare (ignore type args)) |
396 | #'(lambda (value location &optional (offset 0)) |
397 | (setf (sap-ref-single location offset) (coerce value 'single-float))))) |
310da1d5 |
398 | |
9adccb27 |
399 | (defmethod reader-function ((type (eql 'single-float)) &rest args) |
400 | (declare (ignore type args)) |
401 | #'(lambda (sap &optional (offset 0)) |
402 | (sap-ref-single sap offset))) |
310da1d5 |
403 | |
404 | |
9adccb27 |
405 | (defmethod alien-type ((type (eql 'double-float)) &rest args) |
406 | (declare (ignore type args)) |
407 | 'alien:double-float) |
310da1d5 |
408 | |
9adccb27 |
409 | (defmethod size-of ((type (eql 'double-float)) &rest args) |
410 | (declare (ignore type args)) |
411 | +size-of-float+) |
310da1d5 |
412 | |
9adccb27 |
413 | (defmethod writer-function ((type (eql 'double-float)) &rest args) |
414 | (declare (ignore type args)) |
415 | #'(lambda (value location &optional (offset 0)) |
416 | (setf (sap-ref-double location offset) (coerce value 'double-float)))) |
310da1d5 |
417 | |
9adccb27 |
418 | (defmethod reader-function ((type (eql 'double-float)) &rest args) |
419 | (declare (ignore type args)) |
420 | #'(lambda (sap &optional (offset 0)) |
421 | (sap-ref-double sap offset))) |
310da1d5 |
422 | |
423 | |
9adccb27 |
424 | (defmethod alien-type ((type (eql 'base-char)) &rest args) |
425 | (declare (ignore type args)) |
426 | 'c-call:char) |
310da1d5 |
427 | |
9adccb27 |
428 | (defmethod size-of ((type (eql 'base-char)) &rest args) |
429 | (declare (ignore type args)) |
310da1d5 |
430 | 1) |
431 | |
9adccb27 |
432 | (defmethod writer-function ((type (eql 'base-char)) &rest args) |
433 | (declare (ignore type args)) |
434 | #'(lambda (char location &optional (offset 0)) |
435 | (setf (sap-ref-8 location offset) (char-code char)))) |
310da1d5 |
436 | |
9adccb27 |
437 | (defmethod reader-function ((type (eql 'base-char)) &rest args) |
438 | (declare (ignore type args)) |
439 | #'(lambda (location &optional (offset 0)) |
440 | (code-char (sap-ref-8 location offset)))) |
310da1d5 |
441 | |
442 | |
9adccb27 |
443 | (defmethod alien-type ((type (eql 'string)) &rest args) |
444 | (declare (ignore type args)) |
445 | (alien-type 'pointer)) |
310da1d5 |
446 | |
9adccb27 |
447 | (defmethod size-of ((type (eql 'string)) &rest args) |
448 | (declare (ignore type args)) |
449 | (size-of 'pointer)) |
310da1d5 |
450 | |
9adccb27 |
451 | (defmethod to-alien-form (string (type (eql 'string)) &rest args) |
452 | (declare (ignore type args)) |
310da1d5 |
453 | `(let ((string ,string)) |
454 | ;; Always copy strings to prevent seg fault due to GC |
455 | (copy-memory |
456 | (make-pointer (1+ (kernel:get-lisp-obj-address string))) |
457 | (1+ (length string))))) |
310da1d5 |
458 | |
9adccb27 |
459 | (defmethod to-alien-function ((type (eql 'string)) &rest args) |
460 | (declare (ignore type args)) |
461 | #'(lambda (string) |
462 | (copy-memory |
463 | (make-pointer (1+ (kernel:get-lisp-obj-address string))) |
464 | (1+ (length string))))) |
465 | |
466 | (defmethod from-alien-form (string (type (eql 'string)) &rest args) |
467 | (declare (ignore type args)) |
468 | `(let ((string ,string)) |
469 | (unless (null-pointer-p string) |
470 | (c-call::%naturalize-c-string string)))) |
310da1d5 |
471 | |
9adccb27 |
472 | (defmethod from-alien-function ((type (eql 'string)) &rest args) |
473 | (declare (ignore type args)) |
474 | #'(lambda (string) |
475 | (unless (null-pointer-p string) |
476 | (c-call::%naturalize-c-string string)))) |
310da1d5 |
477 | |
9adccb27 |
478 | (defmethod cleanup-form (string (type (eql 'string)) &rest args) |
479 | (declare (ignore type args)) |
480 | `(let ((string ,string)) |
481 | (unless (null-pointer-p string) |
482 | (deallocate-memory string)))) |
483 | |
484 | (defmethod cleanup-function ((type (eql 'string)) &rest args) |
485 | #'(lambda (string) |
486 | (unless (null-pointer-p string) |
487 | (deallocate-memory string)))) |
488 | |
489 | (defmethod writer-function ((type (eql 'string)) &rest args) |
490 | (declare (ignore type args)) |
491 | #'(lambda (string location &optional (offset 0)) |
492 | (assert (null-pointer-p (sap-ref-sap location offset))) |
493 | (setf (sap-ref-sap location offset) |
494 | (copy-memory |
495 | (make-pointer (1+ (kernel:get-lisp-obj-address string))) |
496 | (1+ (length string)))))) |
497 | |
498 | (defmethod reader-function ((type (eql 'string)) &rest args) |
499 | (declare (ignore type args)) |
500 | #'(lambda (location &optional (offset 0)) |
501 | (unless (null-pointer-p (sap-ref-sap location offset)) |
502 | (c-call::%naturalize-c-string (sap-ref-sap location offset))))) |
503 | |
504 | (defmethod destroy-function ((type (eql 'string)) &rest args) |
505 | (declare (ignore type args)) |
506 | #'(lambda (location &optional (offset 0)) |
507 | (unless (null-pointer-p (sap-ref-sap location offset)) |
508 | (deallocate-memory (sap-ref-sap location offset)) |
509 | (setf (sap-ref-sap location offset) (make-pointer 0))))) |
510 | |
511 | |
512 | (defmethod alien-type ((type (eql 'pathname)) &rest args) |
513 | (declare (ignore type args)) |
514 | (alien-type 'string)) |
515 | |
516 | (defmethod size-of ((type (eql 'pathname)) &rest args) |
517 | (declare (ignore type args)) |
518 | (size-of 'string)) |
310da1d5 |
519 | |
9adccb27 |
520 | (defmethod to-alien-form (path (type (eql 'pathname)) &rest args) |
521 | (declare (ignore type args)) |
522 | (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string)) |
523 | |
524 | (defmethod to-alien-function ((type (eql 'pathname)) &rest args) |
525 | (declare (ignore type args)) |
526 | (let ((string-function (to-alien-function 'string))) |
527 | #'(lambda (path) |
528 | (funcall string-function (namestring path))))) |
529 | |
530 | (defmethod from-alien-form (string (type (eql 'pathname)) &rest args) |
531 | (declare (ignore type args)) |
532 | `(parse-namestring ,(from-alien-form string 'string))) |
533 | |
534 | (defmethod from-alien-function ((type (eql 'pathname)) &rest args) |
535 | (declare (ignore type args)) |
536 | (let ((string-function (from-alien-function 'string))) |
537 | #'(lambda (string) |
538 | (parse-namestring (funcall string-function string))))) |
539 | |
540 | (defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args) |
541 | (declare (ignore type args)) |
542 | (cleanup-form string 'string)) |
543 | |
544 | (defmethod cleanup-function ((type (eql 'pathnanme)) &rest args) |
545 | (declare (ignore type args)) |
546 | (cleanup-function 'string)) |
547 | |
548 | (defmethod writer-function ((type (eql 'pathname)) &rest args) |
549 | (declare (ignore type args)) |
550 | (let ((string-writer (writer-function 'string))) |
551 | #'(lambda (path location &optional (offset 0)) |
552 | (funcall string-writer (namestring path) location offset)))) |
553 | |
554 | (defmethod reader-function ((type (eql 'pathname)) &rest args) |
555 | (declare (ignore type args)) |
556 | (let ((string-reader (reader-function 'string))) |
557 | #'(lambda (location &optional (offset 0)) |
558 | (let ((string (funcall string-reader location offset))) |
559 | (when string |
560 | (parse-namestring string)))))) |
561 | |
562 | (defmethod destroy-function ((type (eql 'pathname)) &rest args) |
563 | (declare (ignore type args)) |
564 | (destroy-function 'string)) |
565 | |
566 | |
567 | (defmethod alien-type ((type (eql 'boolean)) &rest args) |
568 | (apply #'alien-type 'signed-byte args)) |
569 | |
570 | (defmethod size-of ((type (eql 'boolean)) &rest args) |
571 | (apply #'size-of 'signed-byte args)) |
572 | |
573 | (defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args) |
574 | (declare (ignore type args)) |
310da1d5 |
575 | `(if ,boolean 1 0)) |
576 | |
9adccb27 |
577 | (defmethod to-alien-function ((type (eql 'boolean)) &rest args) |
578 | (declare (ignore type args)) |
579 | #'(lambda (boolean) |
580 | (if boolean 1 0))) |
581 | |
582 | (defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args) |
583 | (declare (ignore type args)) |
584 | `(not (zerop ,boolean))) |
585 | |
586 | (defmethod from-alien-function ((type (eql 'boolean)) &rest args) |
587 | (declare (ignore type args)) |
588 | #'(lambda (boolean) |
589 | (not (zerop boolean)))) |
590 | |
591 | (defmethod writer-function ((type (eql 'boolean)) &rest args) |
592 | (declare (ignore type)) |
593 | (let ((writer (apply #'writer-function 'signed-byte args))) |
594 | #'(lambda (boolean location &optional (offset 0)) |
595 | (funcall writer (if boolean 1 0) location offset)))) |
596 | |
597 | (defmethod reader-function ((type (eql 'boolean)) &rest args) |
598 | (declare (ignore type)) |
599 | (let ((reader (apply #'reader-function 'signed-byte args))) |
600 | #'(lambda (location &optional (offset 0)) |
601 | (not (zerop (funcall reader location offset)))))) |
602 | |
603 | |
604 | (defmethod alien-type ((type (eql 'or)) &rest args) |
605 | (let ((alien-type (alien-type (first args)))) |
606 | (unless (every #'(lambda (type) |
607 | (eq alien-type (alien-type type))) |
608 | (rest args)) |
609 | (error "No common alien type specifier for union type: ~A" |
610 | (cons type args))) |
310da1d5 |
611 | alien-type)) |
612 | |
9adccb27 |
613 | (defmethod size-of ((type (eql 'or)) &rest args) |
614 | (declare (ignore type)) |
615 | (size-of (first args))) |
616 | |
617 | (defmethod to-alien-form (form (type (eql 'or)) &rest args) |
618 | (declare (ignore type)) |
619 | `(let ((value ,form)) |
620 | (etypecase value |
621 | ,@(mapcar |
622 | #'(lambda (type) |
623 | `(,type ,(to-alien-form 'value type))) |
624 | args)))) |
625 | |
626 | (defmethod to-alien-function ((type (eql 'or)) &rest types) |
627 | (declare (ignore type)) |
628 | (let ((functions (mapcar #'to-alien-function types))) |
629 | #'(lambda (value) |
630 | (loop |
631 | for function in functions |
632 | for type in types |
633 | when (typep value type) |
634 | do (return (funcall function value)) |
635 | finally (error "~S is not of type ~A" value `(or ,@types)))))) |
636 | |
637 | (defmethod alien-type ((type (eql 'system-area-pointer)) &rest args) |
638 | (declare (ignore type args)) |
310da1d5 |
639 | 'system-area-pointer) |
640 | |
9adccb27 |
641 | (defmethod size-of ((type (eql 'system-area-pointer)) &rest args) |
642 | (declare (ignore type args)) |
643 | +size-of-pointer+) |
310da1d5 |
644 | |
9adccb27 |
645 | (defmethod writer-function ((type (eql 'system-area-pointer)) &rest args) |
646 | (declare (ignore type args)) |
647 | #'(lambda (sap location &optional (offset 0)) |
648 | (setf (sap-ref-sap location offset) sap))) |
310da1d5 |
649 | |
9adccb27 |
650 | (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args) |
651 | (declare (ignore type args)) |
652 | #'(lambda (location &optional (offset 0)) |
653 | (sap-ref-sap location offset))) |
310da1d5 |
654 | |
655 | |
9adccb27 |
656 | (defmethod alien-type ((type (eql 'null)) &rest args) |
657 | (declare (ignore type args)) |
658 | (alien-type 'pointer)) |
310da1d5 |
659 | |
9adccb27 |
660 | (defmethod size-of ((type (eql 'null)) &rest args) |
661 | (declare (ignore type args)) |
662 | (size-of 'pointer)) |
663 | |
664 | (defmethod to-alien-form (null (type (eql 'null)) &rest args) |
665 | (declare (ignore null type args)) |
310da1d5 |
666 | `(make-pointer 0)) |
667 | |
9adccb27 |
668 | (defmethod to-alien-function ((type (eql 'null)) &rest args) |
669 | (declare (ignore type args)) |
670 | #'(lambda (null) |
671 | (declare (ignore null)) |
672 | (make-pointer 0))) |
310da1d5 |
673 | |
310da1d5 |
674 | |
9adccb27 |
675 | (defmethod alien-type ((type (eql 'nil)) &rest args) |
676 | (declare (ignore type args)) |
677 | 'c-call:void) |
678 | |
679 | (defmethod from-alien-function ((type (eql 'nil)) &rest args) |
680 | (declare (ignore type args)) |
681 | #'(lambda (value) |
682 | (declare (ignore value)) |
683 | (values))) |