1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
4 ;; Permission is hereby granted, free of charge, to any person obtaining
5 ;; a copy of this software and associated documentation files (the
6 ;; "Software"), to deal in the Software without restriction, including
7 ;; without limitation the rights to use, copy, modify, merge, publish,
8 ;; distribute, sublicense, and/or sell copies of the Software, and to
9 ;; permit persons to whom the Software is furnished to do so, subject to
10 ;; the following conditions:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
23 ;; $Id: basic-types.lisp,v 1.2 2006-06-08 13:24:25 espen Exp $
29 '(signed-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:int)
30 #+clisp #.(ffi:bitsizeof 'ffi:int)
31 #-(or sbcl clisp) 32))
32 (deftype unsigned-int ()
33 '(unsigned-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:int)
34 #+clisp #.(ffi:bitsizeof 'ffi:int)
35 #-(or sbcl clisp) 32))
37 '(signed-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:long)
38 #+clisp #.(ffi:bitsizeof 'ffi:long)
39 #-(or sbcl clisp) 32))
40 (deftype unsigned-long ()
41 '(unsigned-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:long)
42 #+clisp #.(ffi:bitsizeof 'ffi:long)
43 #-(or sbcl clisp) 32))
45 '(signed-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:short)
46 #+clisp #.(ffi:bitsizeof 'ffi:short)
47 #-(or sbcl clisp) 16))
48 (deftype unsigned-short ()
49 '(unsigned-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:short)
50 #+clisp #.(ffi:bitsizeof 'ffi:short)
51 #-(or sbcl clisp) 16))
52 (deftype signed (&optional (size '*)) `(signed-byte ,size))
53 (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
54 (deftype char () 'base-char)
56 #+(or cmu sbcl) 'system-area-pointer
57 #+clisp 'ffi:foreign-address)
58 (deftype bool (&optional (size '*)) (declare (ignore size)) 'boolean)
59 (deftype copy-of (type) type)
60 (deftype static (type) type)
61 (deftype inlined (type) type)
65 (define-type-generic alien-type (type)
66 "Returns the foreign type corresponding to TYPE")
67 (define-type-generic size-of (type &key inlined)
68 "Returns the foreign size of TYPE. The default value of INLINED is
69 T for basic C types and NIL for other types.")
70 (define-type-generic type-alignment (type &key inlined)
71 "Returns the alignment of TYPE. The default value of INLINED is
72 T for basic C types and NIL for other types.")
73 (define-type-generic alien-arg-wrapper (type var arg style form &optional copy-p)
74 "Creates a wrapper around FORM which binds the alien translation of
75 ARG to VAR in a way which makes it possible to pass the location of
76 VAR in a foreign function call. It should also do any necessary clean
77 up before returning the value of FORM.")
78 (define-type-generic to-alien-form (type form &optional copy-p)
79 "Returns a form which translates FORM to alien representation. If
80 COPY-P is non NIL then any allocated foreign memory must not be
82 (define-type-generic from-alien-form (type form &key ref)
83 "Returns a form which translates FORM from alien to lisp
84 representation. REF should be :FREE, :COPY, :STATIC or :TEMP")
85 (define-type-generic to-alien-function (type &optional copy-p)
86 "Returns a function of one argument which will translate objects of the given type to alien repesentation. An optional function, taking the origional object and the alien representation as arguments, to clean up after the alien value is not needed any more may be returned as a second argument.")
87 (define-type-generic from-alien-function (type &key ref)
88 "Returns a function of one argument which will translate alien objects of the given type to lisp representation. REF should be :FREE, :COPY, :STATIC or :TEMP")
89 (define-type-generic callback-wrapper (type var arg form)
90 "Creates a wrapper around FORM which binds the lisp translation of
91 ARG to VAR during a C callback.")
93 (define-type-generic writer-function (type &key temp inlined)
94 "Returns a function taking a value, an address and an optional
95 offset which when called will write a reference an object at the given
96 location. If TEMP is non NIL then the object is expected to be valid
97 as long as the reference exists.")
98 (define-type-generic reader-function (type &key ref inlined)
99 "Returns a function taking an address and optional offset which when
100 called will return the object at given location. REF should be :READ,
102 (define-type-generic destroy-function (type &key temp inlined)
103 "Returns a function taking an address and optional offset which when
104 called will destroy the reference at the given location. This may
105 involve freeing the foreign object being referenced or decreasing it's
106 ref. count. If TEMP is non NIL then the reference is expected to
107 have been written as temporal.")
108 (define-type-generic copy-function (type &key inlined))
110 (define-type-generic unbound-value (type-spec)
111 "Returns a value which should be interpreted as unbound for slots with virtual allocation")
113 (defun assert-inlined (type inlined-p)
115 (error "Type ~A can only be inlined" type)))
117 (defun assert-not-inlined (type inlined-p)
119 (error "Type ~A can not be inlined" type)))
122 (define-type-method alien-arg-wrapper ((type t) var arg style form &optional
123 (copy-in-p nil copy-in-given-p))
124 (let ((alien-type (alien-type type)))
127 (let ((to-alien (if copy-in-given-p
128 (to-alien-form type arg copy-in-p)
129 (to-alien-form type arg))))
131 `(with-alien ((,var ,alien-type ,to-alien))
134 `(ffi:with-c-var (,var ',alien-type ,to-alien)
138 `(with-alien ((,var ,alien-type))
139 (clear-memory (alien-sap (addr ,var)) ,(size-of type))
142 `(ffi:with-c-var (,var ',alien-type)
145 (define-type-method callback-wrapper ((type t) var arg form)
146 `(let ((,var ,(from-alien-form type arg :ref :temp)))
149 (define-type-method alien-type ((type t))
150 (error "No alien type corresponding to the type specifier ~A" type))
152 (define-type-method to-alien-form ((type t) form &optional copy-p)
153 (declare (ignore form copy-p))
154 (error "Not a valid type specifier for arguments: ~A" type))
156 (define-type-method to-alien-function ((type t) &optional copy-p)
157 (declare (ignore copy-p))
158 (error "Not a valid type specifier for arguments: ~A" type))
160 (define-type-method from-alien-form ((type t) form &key ref)
161 (declare (ignore form ref))
162 (error "Not a valid type specifier for return values: ~A" type))
164 (define-type-method from-alien-function ((type t) &key ref)
165 (declare (ignore ref))
166 (error "Not a valid type specifier for return values: ~A" type))
168 (define-type-method destroy-function ((type t) &key temp (inlined t inlined-p))
169 (declare (ignore temp))
170 (let ((size (if inlined-p
171 (size-of type :inlined inlined)
173 #'(lambda (location &optional (offset 0))
174 (clear-memory location size offset))))
176 (define-type-method copy-function ((type t) &key (inlined t inlined-p))
177 (let ((size (if inlined-p
178 (size-of type :inlined inlined)
180 #'(lambda (from to &optional (offset 0))
181 (copy-memory (pointer+ from offset) size (pointer+ to offset)))))
183 (define-type-method to-alien-form ((type real) form &optional copy-p)
184 (declare (ignore type copy-p))
187 (define-type-method to-alien-function ((type real) &optional copy-p)
188 (declare (ignore type copy-p))
191 (define-type-method from-alien-form ((type real) form &key ref)
192 (declare (ignore type ref))
195 (define-type-method from-alien-function ((type real) &key ref)
196 (declare (ignore type ref))
200 (define-type-method alien-type ((type integer))
201 (declare (ignore type))
202 (alien-type 'signed-byte))
204 (define-type-method size-of ((type integer) &key (inlined t))
205 (declare (ignore type))
206 (size-of 'signed-byte :inlined inlined))
208 (define-type-method type-alignment ((type integer) &key (inlined t))
209 (declare (ignore type))
210 (type-alignment 'signed-byte :inlined inlined))
212 (define-type-method writer-function ((type integer) &key temp (inlined t))
213 (declare (ignore temp))
214 (assert-inlined type inlined)
215 (writer-function 'signed-byte))
217 (define-type-method reader-function ((type integer) &key ref (inlined t))
218 (declare (ignore ref))
219 (assert-inlined type inlined)
220 (reader-function 'signed-byte))
225 (define-type-method alien-type ((type signed-byte))
226 (destructuring-bind (&optional (size '*))
227 (rest (mklist (type-expand-to 'signed-byte type)))
228 (let ((size (if (eq size '*)
229 (second (type-expand-to 'signed-byte 'int))
233 ( 8 '(alien:signed 8))
234 (16 '(alien:signed 16))
235 (32 '(alien:signed 32))
236 (64 '(alien:signed 64)))
239 ( 8 '(sb-alien:signed 8))
240 (16 '(sb-alien:signed 16))
241 (32 '(sb-alien:signed 32))
242 (64 '(sb-alien:signed 64)))
250 (define-type-method size-of ((type signed-byte) &key (inlined t))
251 (assert-inlined type inlined)
252 (destructuring-bind (&optional (size '*))
253 (rest (mklist (type-expand-to 'signed-byte type)))
254 (let ((size (if (eq size '*)
255 (second (type-expand-to 'signed-byte 'int))
263 (define-type-method type-alignment ((type signed-byte) &key (inlined t))
264 (assert-inlined type inlined)
265 (destructuring-bind (&optional (size '*))
266 (rest (mklist (type-expand-to 'signed-byte type)))
267 (let ((size (if (eq size '*)
268 (second (type-expand-to 'signed-byte 'int))
270 #+sbcl(sb-alignment `(sb-alien:signed ,size))
272 ( 8 (nth-value 1 (ffi:sizeof 'ffi:sint8)))
273 (16 (nth-value 1 (ffi:sizeof 'ffi:sint16)))
274 (32 (nth-value 1 (ffi:sizeof 'ffi:sint32)))
275 (64 (nth-value 1 (ffi:sizeof 'ffi:sint64))))
276 #-(or sbcl clisp) 4)))
278 (define-type-method writer-function ((type signed-byte) &key temp (inlined t))
279 (declare (ignore temp))
280 (assert-inlined type inlined)
281 (destructuring-bind (&optional (size '*))
282 (rest (mklist (type-expand-to 'signed-byte type)))
283 (let ((size (if (eq size '*)
284 (second (type-expand-to 'signed-byte 'int))
287 ( 8 #'(lambda (value location &optional (offset 0))
289 #+(or cmu sbcl)(signed-sap-ref-8 location offset)
290 #+clisp(ffi:memory-as location 'ffi:sint8 offset)
292 (16 #'(lambda (value location &optional (offset 0))
294 #+(or cmu sbcl)(signed-sap-ref-16 location offset)
295 #+clisp(ffi:memory-as location 'ffi:sint16 offset)
297 (32 #'(lambda (value location &optional (offset 0))
299 #+(or cmu sbcl)(signed-sap-ref-32 location offset)
300 #+clisp(ffi:memory-as location 'ffi:sint32 offset)
302 (64 #'(lambda (value location &optional (offset 0))
304 #+(or cmu sbcl)(signed-sap-ref-64 location offset)
305 #+clisp(ffi:memory-as location 'ffi:sint64 offset)
308 (define-type-method reader-function ((type signed-byte) &key ref (inlined t))
309 (declare (ignore ref))
310 (assert-inlined type inlined)
311 (destructuring-bind (&optional (size '*))
312 (rest (mklist (type-expand-to 'signed-byte type)))
313 (let ((size (if (eq size '*)
314 (second (type-expand-to 'signed-byte 'int))
317 ( 8 #'(lambda (location &optional (offset 0))
318 #+(or cmu sbcl)(signed-sap-ref-8 location offset)
319 #+clisp(ffi:memory-as location 'ffi:sint8 offset)))
320 (16 #'(lambda (location &optional (offset 0))
321 #+(or cmu sbcl)(signed-sap-ref-16 location offset)
322 #+clisp(ffi:memory-as location 'ffi:sint16 offset)))
323 (32 #'(lambda (location &optional (offset 0))
324 #+(or cmu sbcl)(signed-sap-ref-32 location offset)
325 #+clisp(ffi:memory-as location 'ffi:sint32 offset)))
326 (64 #'(lambda (location &optional (offset 0))
327 #+(or cmu sbcl)(signed-sap-ref-64 location offset)
328 #+clisp(ffi:memory-as location 'ffi:sint64 offset)))))))
334 (define-type-method alien-type ((type unsigned-byte))
335 (destructuring-bind (&optional (size '*))
336 (rest (mklist (type-expand-to 'unsigned-byte type)))
337 (let ((size (if (eq size '*)
338 (second (type-expand-to 'signed-byte 'int))
342 ( 8 '(alien:unsigned 8))
343 (16 '(alien:unsigned 16))
344 (32 '(alien:unsigned 32))
345 (64 '(alien:unsigned 64)))
348 ( 8 '(sb-alien:unsigned 8))
349 (16 '(sb-alien:unsigned 16))
350 (32 '(sb-alien:unsigned 32))
351 (64 '(sb-alien:unsigned 64)))
359 (define-type-method size-of ((type unsigned-byte) &key (inlined t))
360 (assert-inlined type inlined)
361 (destructuring-bind (&optional (size '*))
362 (rest (mklist (type-expand-to 'unsigned-byte type)))
363 (size-of `(signed ,size))))
365 (define-type-method type-alignment ((type unsigned-byte) &key (inlined t))
366 (assert-inlined type inlined)
367 (destructuring-bind (&optional (size '*))
368 (rest (mklist (type-expand-to 'unsigned-byte type)))
369 (type-alignment `(signed ,size))))
371 (define-type-method writer-function ((type unsigned-byte) &key temp (inlined t))
372 (declare (ignore temp))
373 (assert-inlined type inlined)
374 (destructuring-bind (&optional (size '*))
375 (rest (mklist (type-expand-to 'unsigned-byte type)))
376 (let ((size (if (eq size '*)
377 (second (type-expand-to 'signed-byte 'int))
380 ( 8 #'(lambda (value location &optional (offset 0))
382 #+(or cmu sbcl)(sap-ref-8 location offset)
383 #+clisp(ffi:memory-as location 'ffi:uint8 offset)
385 (16 #'(lambda (value location &optional (offset 0))
387 #+(or cmu sbcl)(sap-ref-16 location offset)
388 #+clisp(ffi:memory-as location 'ffi:uint16 offset)
390 (32 #'(lambda (value location &optional (offset 0))
392 #+(or cmu sbcl)(sap-ref-32 location offset)
393 #+clisp(ffi:memory-as location 'ffi:uint32 offset)
395 (64 #'(lambda (value location &optional (offset 0))
397 #+(or cmu sbcl)(sap-ref-64 location offset)
398 #+clisp(ffi:memory-as location 'ffi:uint64 offset)
401 (define-type-method reader-function ((type unsigned-byte) &key ref (inlined t))
402 (declare (ignore ref))
403 (assert-inlined type inlined)
404 (destructuring-bind (&optional (size '*))
405 (rest (mklist (type-expand-to 'unsigned-byte type)))
406 (let ((size (if (eq size '*)
407 (second (type-expand-to 'signed-byte 'int))
410 ( 8 #'(lambda (location &optional (offset 0))
411 #+(or cmu sbcl)(sap-ref-8 location offset)
412 #+clisp(ffi:memory-as location 'ffi:uint8 offset)))
413 (16 #'(lambda (location &optional (offset 0))
414 #+(or cmu sbcl)(sap-ref-16 location offset)
415 #+clisp(ffi:memory-as location 'ffi:uint16 offset)))
416 (32 #'(lambda (location &optional (offset 0))
417 #+(or cmu sbcl)(sap-ref-32 location offset)
418 #+clisp(ffi:memory-as location 'ffi:uint32 offset)))
419 (64 #'(lambda (location &optional (offset 0))
420 #+(or cmu sbcl)(sap-ref-64 location offset)
421 #+clisp(ffi:memory-as location 'ffi:uint64 offset)))))))
427 (define-type-method alien-type ((type single-float))
428 (declare (ignore type))
429 #+cmu 'alien:single-float
430 #+sbcl 'sb-alien:single-float
431 #+clisp 'single-float)
433 (define-type-method size-of ((type single-float) &key (inlined t))
434 (assert-inlined type inlined)
435 #+sbcl (sb-sizeof 'sb-alien:float)
436 #+clisp (ffi:sizeof 'single-float)
439 (define-type-method type-alignment ((type single-float) &key (inlined t))
440 (assert-inlined type inlined)
441 #+sbcl (sb-alignment 'single-float)
442 #+clisp (nth-value 1 (ffi:sizeof 'single-float))
445 (define-type-method to-alien-form ((type single-float) form &optional copy-p)
446 (declare (ignore type copy-p))
447 `(coerce ,form 'single-float))
449 (define-type-method to-alien-function ((type single-float) &optional copy-p)
450 (declare (ignore type copy-p))
452 (coerce number 'single-float)))
454 (define-type-method writer-function ((type single-float) &key temp (inlined t))
455 (declare (ignore temp))
456 (assert-inlined type inlined)
457 #'(lambda (value location &optional (offset 0))
459 #+(or cmu sbcl)(sap-ref-single location offset)
460 #+clisp(ffi:memory-as location 'single-float offset)
461 (coerce value 'single-float))))
463 (define-type-method reader-function ((type single-float) &key ref (inlined t))
464 (declare (ignore ref))
465 (assert-inlined type inlined)
466 #'(lambda (location &optional (offset 0))
467 #+(or cmu sbcl)(sap-ref-single location offset)
468 #+clisp(ffi:memory-as location 'single-float offset)))
474 (define-type-method alien-type ((type double-float))
475 (declare (ignore type))
476 #+cmu 'alien:double-float
477 #+sbcl 'sb-alien:double-float
478 #+clisp 'double-float)
480 (define-type-method size-of ((type double-float) &key (inlined t))
481 (assert-inlined type inlined)
482 #+sbcl (sb-sizeof 'sb-alien:double)
483 #+clisp (ffi:sizeof 'double-float)
486 (define-type-method type-alignment ((type double-float) &key (inlined t))
487 (assert-inlined type inlined)
488 #+sbcl (sb-alignment 'double-float)
489 #+clisp (nth-value 1 (ffi:sizeof 'double-float))
492 (define-type-method to-alien-form ((type double-float) form &optional copy-p)
493 (declare (ignore type copy-p))
494 `(coerce ,form 'double-float))
496 (define-type-method to-alien-function ((type double-float) &optional copy-p)
497 (declare (ignore type copy-p))
499 (coerce number 'double-float)))
501 (define-type-method writer-function ((type double-float) &key temp (inlined t))
502 (declare (ignore temp))
503 (assert-inlined type inlined)
504 #'(lambda (value location &optional (offset 0))
506 #+(or cmu sbcl)(sap-ref-double location offset)
507 #+clisp(ffi:memory-as location 'double-float offset)
508 (coerce value 'double-float))))
510 (define-type-method reader-function ((type double-float) &key ref (inlined t))
511 (declare (ignore ref))
512 (assert-inlined type inlined)
513 #'(lambda (location &optional (offset 0))
514 #+(or cmu sbcl)(sap-ref-double location offset)
515 #+clisp(ffi:memory-as location 'double-float offset)))
521 (define-type-method alien-type ((type base-char))
522 (declare (ignore type))
524 #+sbcl 'sb-alien:char
525 #+clisp 'ffi:character)
527 (define-type-method size-of ((type base-char) &key (inlined t))
528 (assert-inlined type inlined)
531 (define-type-method type-alignment ((type base-char) &key (inlined t))
532 (assert-inlined type inlined)
533 #+sbcl (sb-alignment 'sb-alien:char)
534 #+clisp (nth-value 1 (ffi:sizeof 'ffi:character))
537 (define-type-method to-alien-form ((type base-char) form &optional copy-p)
538 (declare (ignore type copy-p))
541 (define-type-method to-alien-function ((type base-char) &optional copy-p)
542 (declare (ignore type copy-p))
545 (define-type-method from-alien-form ((type base-char) form &key ref)
546 (declare (ignore type ref))
549 (define-type-method from-alien-function ((type base-char) &key ref)
550 (declare (ignore type ref))
553 (define-type-method writer-function ((type base-char) &key temp (inlined t))
554 (declare (ignore temp))
555 (assert-inlined type inlined)
556 #'(lambda (char location &optional (offset 0))
558 (setf (sap-ref-8 location offset) (char-code char))
559 #+clisp(setf (ffi:memory-as location 'ffi:character offset) char)))
561 (define-type-method reader-function ((type base-char) &key ref (inlined t))
562 (declare (ignore ref))
563 (assert-inlined type inlined)
564 #'(lambda (location &optional (offset 0))
565 #+(or cmu sbcl)(code-char (sap-ref-8 location offset))
566 #+clisp(ffi:memory-as location 'ffi:character offset)))
572 (defun utf8-length (string)
574 for char across string
575 as char-code = (char-code char)
577 ((< char-code #x7F) 1)
578 ((< char-code #x7FF) 2)
579 ((< char-code #xFFFF) 3)
580 ((< char-code #x1FFFFF) 4)))))
582 (defun encode-utf8-string (string &optional location)
583 (let ((location (or location (allocate-memory (utf8-length string)))))
585 for char across string
587 as char-code = (char-code char)
588 do (flet ((encode (size)
589 (let ((rem (mod size 6)))
590 (setf (ref-byte location i)
592 #xFF (byte (- 7 rem) (1+ rem))
593 (ldb (byte rem (- size rem)) char-code)))
595 for pos from (- size rem 6) downto 0 by 6
596 do (setf (ref-byte location (incf i))
597 (+ 128 (ldb (byte 6 pos) char-code)))))))
599 ((< char-code #x80) (setf (ref-byte location i) char-code))
600 ((< char-code #x800) (encode 11))
601 ((< char-code #x10000) (encode 16))
602 ((< char-code #x200000) (encode 21))))
603 finally (setf (ref-byte location (1+ i)) 0))
606 (defun decode-utf8-string (c-string)
607 (with-output-to-string (string)
610 as octet = (ref-byte c-string i)
612 do (flet ((decode (size)
614 with rem = (mod size 6)
615 for pos from (- size rem) downto 0 by 6
616 as code = (dpb (ldb (byte rem 0) octet) (byte rem pos) 0)
618 (ldb (byte 6 0) (ref-byte c-string (incf i)))
620 finally (write-char (code-char code) string))))
622 ((< octet 128) (write-char (code-char octet) string))
623 ((< octet 224) (decode 11))
624 ((< octet 240) (decode 16))
625 ((< octet 248) (decode 21)))))))
628 (define-type-method alien-arg-wrapper ((type string) var string style form &optional copy-in-p)
629 (declare (ignore type))
631 ((and (in-arg-p style) copy-in-p)
632 `(with-pointer (,var (encode-utf8-string ,string))
634 ((and (in-arg-p style) (not (out-arg-p style)))
635 `(with-memory (,var (utf8-length ,string))
636 (encode-utf8-string ,string ,var)
638 ((and (in-arg-p style) (out-arg-p style))
639 (let ((c-string (make-symbol "C-STRING")))
640 `(with-memory (,c-string (utf8-length ,string))
641 (encode-utf8-string ,string ,c-string)
642 (with-pointer (,var ,c-string)
644 ((and (out-arg-p style) (not (in-arg-p style)))
645 `(with-pointer (,var)
648 (define-type-method alien-type ((type string))
649 (declare (ignore type))
650 (alien-type 'pointer))
652 (define-type-method size-of ((type string) &key inlined)
653 (assert-not-inlined type inlined)
656 (define-type-method type-alignment ((type string) &key inlined)
657 (assert-not-inlined type inlined)
658 (type-alignment 'pointer))
660 (define-type-method to-alien-form ((type string) string &optional copy-p)
661 (declare (ignore type copy-p))
662 `(encode-utf8-string ,string))
664 (define-type-method to-alien-function ((type string) &optional copy-p)
665 (declare (ignore type))
669 #'(lambda (string c-string)
670 (declare (ignore string))
671 (deallocate-memory c-string)))))
673 (define-type-method from-alien-form ((type string) form &key (ref :free))
674 (declare (ignore type))
675 `(let ((c-string ,form))
676 (unless (null-pointer-p c-string)
678 (decode-utf8-string c-string)
679 ,(when (eq ref :free)
680 `(deallocate-memory c-string))))))
682 (define-type-method from-alien-function ((type string) &key (ref :free))
683 (declare (ignore type))
686 (unless (null-pointer-p c-string)
688 (decode-utf8-string c-string)
689 (deallocate-memory c-string))))
691 (unless (null-pointer-p c-string)
692 (decode-utf8-string c-string)))))
694 (define-type-method writer-function ((type string) &key temp inlined)
695 (declare (ignore temp))
696 (assert-not-inlined type inlined)
697 #'(lambda (string location &optional (offset 0))
698 (assert (null-pointer-p (ref-pointer location offset)))
699 (setf (ref-pointer location offset) (encode-utf8-string string))))
701 (define-type-method reader-function ((type string) &key (ref :read) inlined)
702 (assert-not-inlined type inlined)
705 #'(lambda (location &optional (offset 0))
706 (unless (null-pointer-p (ref-pointer location offset))
707 (decode-utf8-string (ref-pointer location offset)))))
709 #'(lambda (location &optional (offset 0))
710 (unless (null-pointer-p (ref-pointer location offset))
712 (decode-utf8-string (ref-pointer location offset))
713 (deallocate-memory (ref-pointer location offset))
714 (setf (ref-pointer location offset) (make-pointer 0))))))))
716 (define-type-method destroy-function ((type string) &key temp inlined)
717 (declare (ignore temp))
718 (assert-not-inlined type inlined)
719 #'(lambda (location &optional (offset 0))
720 (unless (null-pointer-p (ref-pointer location offset))
721 (deallocate-memory (ref-pointer location offset))
722 (setf (ref-pointer location offset) (make-pointer 0)))))
724 (define-type-method copy-function ((type string) &key inlined)
725 (assert-not-inlined type inlined)
726 (lambda (from to &optional (offset 0))
727 (let* ((string (ref-pointer from offset))
730 until (zerop (ref-byte string i))
731 finally (return (1+ i)))))
732 (setf (ref-pointer to offset) (copy-memory string length)))))
734 (define-type-method unbound-value ((type string))
735 (declare (ignore type))
742 (define-type-method alien-type ((type pathname))
743 (declare (ignore type))
744 (alien-type 'string))
746 (define-type-method size-of ((type pathname) &key inlined)
747 (assert-not-inlined type inlined)
750 (define-type-method type-alignment ((type pathname) &key inlined)
751 (assert-not-inlined type inlined)
752 (type-alignment 'string))
754 (define-type-method alien-arg-wrapper ((type pathname) var pathname style form &optional copy-in-p)
755 (declare (ignore type))
756 (alien-arg-wrapper 'string var `(namestring (translate-logical-pathname ,pathname)) style form copy-in-p))
758 (define-type-method to-alien-form ((type pathname) path)
759 (declare (ignore type))
760 (to-alien-form 'string `(namestring (translate-logical-pathname ,path))))
762 (define-type-method to-alien-function ((type pathname) &optional copy-p)
763 (declare (ignore type))
764 (let ((string-function (to-alien-function 'string copy-p)))
766 (funcall string-function (namestring path)))))
768 (define-type-method from-alien-form ((type pathname) form &key (ref :free))
769 (declare (ignore type))
770 `(parse-namestring ,(from-alien-form 'string form :ref ref)))
772 (define-type-method from-alien-function ((type pathname) &key (ref :free))
773 (declare (ignore type))
774 (let ((string-function (from-alien-function 'string :ref ref)))
776 (parse-namestring (funcall string-function string)))))
778 (define-type-method writer-function ((type pathname) &key temp inlined)
779 (declare (ignore temp))
780 (assert-not-inlined type inlined)
781 (let ((string-writer (writer-function 'string)))
782 #'(lambda (path location &optional (offset 0))
783 (funcall string-writer (namestring path) location offset))))
785 (define-type-method reader-function ((type pathname) &key ref inlined)
786 (declare (ignore ref))
787 (assert-not-inlined type inlined)
788 (let ((string-reader (reader-function 'string)))
789 #'(lambda (location &optional (offset 0))
790 (let ((string (funcall string-reader location offset)))
792 (parse-namestring string))))))
794 (define-type-method destroy-function ((type pathname) &key temp inlined)
795 (declare (ignore temp))
796 (assert-not-inlined type inlined)
797 (destroy-function 'string))
799 (define-type-method copy-function ((type pathname) &key inlined)
800 (assert-not-inlined type inlined)
801 (copy-function 'string))
803 (define-type-method unbound-value ((type pathname))
804 (declare (ignore type))
805 (unbound-value 'string))
811 (define-type-method alien-type ((type bool))
812 (destructuring-bind (&optional (size '*))
813 (rest (mklist (type-expand-to 'bool type)))
814 (alien-type `(signed-byte ,size))))
816 (define-type-method size-of ((type bool) &key (inlined t))
817 (assert-inlined type inlined)
818 (destructuring-bind (&optional (size '*))
819 (rest (mklist (type-expand-to 'bool type)))
820 (size-of `(signed-byte ,size))))
822 (define-type-method type-alignment ((type bool) &key (inlined t))
823 (assert-inlined type inlined)
824 (destructuring-bind (&optional (size '*))
825 (rest (mklist (type-expand-to 'bool type)))
826 (type-alignment `(signed-byte ,size))))
828 (define-type-method to-alien-form ((type bool) bool &optional copy-p)
829 (declare (ignore type copy-p))
832 (define-type-method to-alien-function ((type bool) &optional copy-p)
833 (declare (ignore type copy-p))
837 (define-type-method from-alien-form ((type bool) form &key ref)
838 (declare (ignore type ref))
839 `(not (zerop ,form)))
841 (define-type-method from-alien-function ((type bool) &key ref)
842 (declare (ignore type ref))
846 (define-type-method writer-function ((type bool) &key temp (inlined t))
847 (declare (ignore temp))
848 (assert-inlined type inlined)
849 (destructuring-bind (&optional (size '*))
850 (rest (mklist (type-expand-to 'bool type)))
851 (let ((writer (writer-function `(signed-byte ,size))))
852 #'(lambda (bool location &optional (offset 0))
853 (funcall writer (if bool 1 0) location offset)))))
855 (define-type-method reader-function ((type bool) &key ref (inlined t))
856 (declare (ignore ref))
857 (assert-inlined type inlined)
858 (destructuring-bind (&optional (size '*))
859 (rest (mklist (type-expand-to 'bool type)))
860 (let ((reader (reader-function `(signed-byte ,size))))
861 #'(lambda (location &optional (offset 0))
862 (not (zerop (funcall reader location offset)))))))
868 (define-type-method alien-type ((type boolean))
869 (declare (ignore type))
872 (define-type-method size-of ((type boolean) &key (inlined t))
873 (assert-inlined type inlined)
876 (define-type-method type-alignment ((type boolean) &key (inlined t))
877 (assert-inlined type inlined)
878 (type-alignment 'bool))
880 (define-type-method to-alien-form ((type boolean) boolean &optional copy-p)
881 (declare (ignore type copy-p))
882 (to-alien-form 'bool boolean))
884 (define-type-method to-alien-function ((type boolean) &optional copy-p)
885 (declare (ignore type copy-p))
886 (to-alien-function 'bool))
888 (define-type-method from-alien-form ((type boolean) form &key ref)
889 (declare (ignore type ref))
890 (from-alien-form 'bool form))
892 (define-type-method from-alien-function ((type boolean) &key ref)
893 (declare (ignore type ref))
894 (from-alien-function 'bool))
896 (define-type-method writer-function ((type boolean) &key temp (inlined t))
897 (declare (ignore temp))
898 (assert-inlined type inlined)
899 (writer-function 'bool))
901 (define-type-method reader-function ((type boolean) &key ref (inlined t))
902 (declare (ignore ref))
903 (assert-inlined type inlined)
904 (reader-function 'bool))
909 (define-type-method alien-type ((type or))
910 (let* ((expanded-type (type-expand-to 'or type))
911 (alien-type (alien-type (second expanded-type))))
912 (unless (every #'(lambda (type)
913 (eq alien-type (alien-type type)))
914 (cddr expanded-type))
915 (error "No common alien type specifier for union type: ~A" type))
918 (define-type-method size-of ((type or) &key (inlined nil inlined-p))
920 for subtype in (type-expand-to 'or type)
921 maximize (if inlined-p
922 (size-of subtype inlined)
925 (define-type-method type-alignment ((type or) &key (inlined nil inlined-p))
927 for subtype in (type-expand-to 'or type)
928 maximize (if inlined-p
929 (type-alignment subtype inlined)
930 (type-alignment subtype))))
932 (define-type-method alien-arg-wrapper ((type or) var value style form &optional copy-in-p)
934 ((and (in-arg-p style) (out-arg-p style))
938 `(,type ,(alien-arg-wrapper type var value style form copy-in-p)))
939 (rest (type-expand-to 'or type)))))
941 (let ((body (make-symbol "BODY")))
942 `(flet ((,body (,var)
947 `(,type ,(alien-arg-wrapper type var value style `(,body ,var) copy-in-p)))
948 (rest (type-expand-to 'or type)))))))
951 `(with-alien ((,var ,(alien-type type)))
952 (clear-memory (alien-sap (addr ,var)) ,(size-of type))
955 `(ffi:with-c-var (,var ',(alien-type type))
958 (define-type-method to-alien-form ((type or) form &optional copy-p)
959 `(let ((value ,form))
963 `(,type ,(to-alien-form type 'value copy-p)))
964 (rest (type-expand-to 'or type))))))
966 (define-type-method to-alien-function ((type or) &optional copy-p)
967 (let* ((expanded-type (type-expand-to 'or type))
969 for type in (rest expanded-type)
970 collect (to-alien-function type copy-p))))
973 for function in functions
974 for alt-type in (rest expanded-type)
975 when (typep value alt-type)
976 do (return (funcall function value))
977 finally (error "~S is not of type ~A" value type)))))
982 (define-type-method alien-type ((type pointer))
983 (declare (ignore type))
984 #+(or cmu sbcl) 'system-area-pointer
985 #+clisp 'ffi:c-pointer)
987 (define-type-method size-of ((type pointer) &key (inlined t))
988 (assert-inlined type inlined)
989 #+sbcl (sb-sizeof 'sb-alien:system-area-pointer)
990 #+clisp (ffi:sizeof 'ffi:c-pointer)
993 (define-type-method type-alignment ((type pointer) &key (inlined t))
994 (assert-inlined type inlined)
995 #+sbcl (sb-alignment 'system-area-pointer)
996 #+clisp (ffi:sizeof 'ffi:c-pointer)
997 #-(or sbcl clisp) (size-of 'pointer))
999 (define-type-method to-alien-form ((type pointer) form &optional copy-p)
1000 (declare (ignore type copy-p))
1003 (define-type-method to-alien-function ((type pointer) &optional copy-p)
1004 (declare (ignore type copy-p))
1007 (define-type-method from-alien-form ((type pointer) form &key ref)
1008 (declare (ignore type ref))
1011 (define-type-method from-alien-function ((type pointer) &key ref)
1012 (declare (ignore type ref))
1015 (define-type-method writer-function ((type pointer) &key temp (inlined t))
1016 (declare (ignore temp))
1017 (assert-inlined type inlined)
1018 #'(setf ref-pointer))
1020 (define-type-method reader-function ((type pointer) &key ref (inlined t))
1021 (declare (ignore ref))
1022 (assert-inlined type inlined)
1026 (define-type-method alien-type ((type null))
1027 (declare (ignore type))
1028 (alien-type 'pointer))
1030 (define-type-method size-of ((type null) &key (inlined t))
1031 (assert-inlined type inlined)
1034 (define-type-method to-alien-form ((type null) null &optional copy-p)
1035 (declare (ignore type copy-p))
1036 `(progn ,null (make-pointer 0)))
1038 (define-type-method to-alien-function ((type null) &optional copy-p)
1039 (declare (ignore type copy-p))
1041 (declare (ignore null))
1045 (define-type-method alien-type ((type nil))
1046 (declare (ignore type))
1047 #+(or cmu sbcl) 'void
1050 (define-type-method from-alien-form ((type nil) form &key ref)
1051 (declare (ignore type ref))
1054 (define-type-method from-alien-function ((type nil) &key ref)
1055 (declare (ignore type ref))
1057 (declare (ignore value))
1060 (define-type-method to-alien-form ((type nil) form &optional copy-p)
1061 (declare (ignore type copy-p))
1068 (define-type-method alien-type ((type callback))
1069 (declare (ignore type))
1070 (alien-type 'pointer))
1072 (define-type-method to-alien-form ((type callback) callback &optional copy-p)
1073 (declare (ignore type copy-p))
1074 `(callback-address ,callback))
1080 (define-type-method from-alien-form ((type copy-of) form &key (ref :copy))
1082 (from-alien-form (second (type-expand-to 'copy-of type)) form :ref ref)
1083 (error "Keyword arg :REF to FROM-ALIEN-FORM should be :COPY for type ~A. It was give ~A" type ref)))
1085 (define-type-method from-alien-function ((type copy-of) &key (ref :copy))
1087 (from-alien-function (second (type-expand-to 'copy-of type)) :ref ref)
1088 (error "Keyword arg :REF to FROM-ALIEN-FORM should be :COPY for type ~A. It was give ~A" type ref)))
1090 (define-type-method to-alien-form ((type copy-of) form &optional (copy-p t))
1092 (to-alien-form (second (type-expand-to 'copy-of type)) form t)
1093 (error "COPY-P argument to TO-ALIEN-FORM should always be non NIL for type ~A" type)))
1095 (define-type-method to-alien-function ((type copy-of) &optional (copy-p t))
1097 (to-alien-function (second (type-expand-to 'copy-of type)) t)
1098 (error "COPY-P argument to TO-ALIEN-FUNCTION should always be non NIL for type ~A" type)))
1100 (define-type-method reader-function ((type copy-of) &key (ref :read) (inlined nil inlined-p))
1102 (reader-function (second (type-expand-to 'copy-of type))
1103 :ref (if (eq ref :get) :read ref) :inlined inlined)
1104 (reader-function (second (type-expand-to 'copy-of type))
1105 :ref (if (eq ref :get) :read ref))))
1107 (define-type-method destroy-function ((type copy-of) &key temp inlined)
1108 (declare (ignore type temp inlined))
1109 #'(lambda (location &optional offset)
1110 (declare (ignore location offset))))
1112 (define-type-method copy-function ((type copy-of) &key (inlined nil inlined-p))
1113 (let ((size (if inlined-p
1114 (size-of type :inlined inlined)
1116 #'(lambda (from to &optional (offset 0))
1117 (copy-memory (pointer+ from offset) size (pointer+ to offset)))))
1123 (define-type-method from-alien-form ((type static) form &key (ref :static))
1124 (if (eq ref :static)
1125 (from-alien-form (second (type-expand-to 'static type)) form :ref ref)
1126 (error "Keyword arg :REF to FROM-ALIEN-FORM should be :STATIC for type ~A. It was give ~A" type ref)))
1128 (define-type-method from-alien-function ((type static) &key (ref :static))
1129 (if (eq ref :static)
1130 (from-alien-function (second (type-expand-to 'static type)) :ref ref)
1131 (error "Keyword arg :REF to FROM-ALIEN-FORM should be :STATIC for type ~A. It was give ~A" type ref)))
1133 (define-type-method to-alien-function ((type static) &optional copy-p)
1135 (to-alien-function (second (type-expand-to 'static type)) t)
1136 (error "COPY-P argument to TO-ALIEN-FUNCTION should always be NIL for type ~A" type)))
1138 (define-type-method to-alien-form ((type static) &optional copy-p)
1140 (to-alien-function (second (type-expand-to 'static type)) t)
1141 (error "COPY-P argument to TO-ALIEN-FUNCTION should always be NIL for type ~A" type)))
1143 (define-type-method reader-function ((type static) &key (ref :read) (inlined nil inlined-p))
1145 (reader-function (second (type-expand-to 'static type))
1146 :ref (if (eq ref :get) :read ref) :inlined inlined)
1147 (reader-function (second (type-expand-to 'static type))
1148 :ref (if (eq ref :get) :read ref))))
1150 (define-type-method writer-function ((type static) &key temp inlined)
1151 (declare (ignore type temp inlined))
1152 (error "Can't overwrite a static (const) reference"))
1154 (define-type-method destroy-function ((type static) &key temp inlined)
1155 (declare (ignore type temp inlined))
1156 #'(lambda (location &optional offset)
1157 (declare (ignore location offset))))
1159 (define-type-method copy-function ((type static) &key (inlined nil inlined-p))
1160 (let ((size (if inlined-p
1161 (size-of type :inlined inlined)
1163 #'(lambda (from to &optional (offset 0))
1164 (copy-memory (pointer+ from offset) size (pointer+ to offset)))))
1168 ;;; Pseudo type for inlining of types which are not inlined by default
1170 (define-type-method size-of ((type inlined) &key (inlined t))
1171 (assert-inlined type inlined)
1172 (size-of (second (type-expand-to 'inlined type)) :inlined t))
1174 (define-type-method type-alignment ((type inlined) &key (inlined t))
1175 (assert-inlined type inlined)
1176 (type-alignment (second (type-expand-to 'inlined type)) :inlined t))
1178 (define-type-method reader-function ((type inlined) &key (ref :read) (inlined t))
1179 (assert-inlined type inlined)
1180 (reader-function (second (type-expand-to 'inlined type)) :ref ref :inlined t))
1182 (define-type-method writer-function ((type inlined) &key temp (inlined t))
1183 (assert-inlined type inlined)
1184 (writer-function (second (type-expand-to 'inlined type)) :temp temp :inlined t))
1186 (define-type-method destroy-function ((type inlined) &key temp (inlined t))
1187 (assert-inlined type inlined)
1188 (destroy-function (second (type-expand-to 'inlined type)) :temp temp :inlined t))
1190 (define-type-method copy-function ((type inlined) &key (inlined t))
1191 (assert-inlined type inlined)
1192 (copy-function (second (type-expand-to 'inlined type)) :inlined t))