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