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