chiark / gitweb /
Bug fix
[clg] / gffi / basic-types.lisp
CommitLineData
beae6579 1;; Common Lisp bindings for GTK+ v2.x
2;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
3;;
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:
11;;
12;; The above copyright notice and this permission notice shall be
13;; included in all copies or substantial portions of the Software.
14;;
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.
22
e5214c13 23;; $Id: basic-types.lisp,v 1.11 2008-03-25 02:00:58 espen Exp $
beae6579 24
25(in-package "GFFI")
26
27
2c708568 28(deftype byte () '(unsigned-byte 8))
beae6579 29(deftype int ()
30 '(signed-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:int)
31 #+clisp #.(ffi:bitsizeof 'ffi:int)
32 #-(or sbcl clisp) 32))
33(deftype unsigned-int ()
34 '(unsigned-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:int)
35 #+clisp #.(ffi:bitsizeof 'ffi:int)
36 #-(or sbcl clisp) 32))
37(deftype long ()
38 '(signed-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:long)
39 #+clisp #.(ffi:bitsizeof 'ffi:long)
40 #-(or sbcl clisp) 32))
41(deftype unsigned-long ()
42 '(unsigned-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:long)
43 #+clisp #.(ffi:bitsizeof 'ffi:long)
44 #-(or sbcl clisp) 32))
45(deftype short ()
46 '(signed-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:short)
47 #+clisp #.(ffi:bitsizeof 'ffi:short)
48 #-(or sbcl clisp) 16))
49(deftype unsigned-short ()
50 '(unsigned-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:short)
51 #+clisp #.(ffi:bitsizeof 'ffi:short)
52 #-(or sbcl clisp) 16))
53(deftype signed (&optional (size '*)) `(signed-byte ,size))
54(deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
55(deftype char () 'base-char)
db71d84e 56(deftype pointer-data ()
57 '(unsigned-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:system-area-pointer)
58 #+clisp #.(ffi:bitsizeof 'ffi:c-pointer)
59 #-(or sbcl clisp) 32))
60
beae6579 61(deftype bool (&optional (size '*)) (declare (ignore size)) 'boolean)
62(deftype copy-of (type) type)
63(deftype static (type) type)
64(deftype inlined (type) type)
65
66
67
68(define-type-generic alien-type (type)
69 "Returns the foreign type corresponding to TYPE")
2c708568 70(define-type-generic argument-type (type)
71 "Returns the type to be used in argument declarations for TYPE.")
72(define-type-generic return-type (type)
73 "Returns the type to be used in return type declarations for TYPE.")
beae6579 74(define-type-generic size-of (type &key inlined)
75 "Returns the foreign size of TYPE. The default value of INLINED is
76T for basic C types and NIL for other types.")
90e8bbf6 77(define-type-generic type-alignment (type &key inlined)
78 "Returns the alignment of TYPE. The default value of INLINED is
79T for basic C types and NIL for other types.")
beae6579 80(define-type-generic alien-arg-wrapper (type var arg style form &optional copy-p)
81 "Creates a wrapper around FORM which binds the alien translation of
82ARG to VAR in a way which makes it possible to pass the location of
83VAR in a foreign function call. It should also do any necessary clean
84up before returning the value of FORM.")
85(define-type-generic to-alien-form (type form &optional copy-p)
86 "Returns a form which translates FORM to alien representation. If
87COPY-P is non NIL then any allocated foreign memory must not be
88reclaimed later.")
89(define-type-generic from-alien-form (type form &key ref)
90 "Returns a form which translates FORM from alien to lisp
91representation. REF should be :FREE, :COPY, :STATIC or :TEMP")
92(define-type-generic to-alien-function (type &optional copy-p)
93 "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.")
94(define-type-generic from-alien-function (type &key ref)
95 "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")
96(define-type-generic callback-wrapper (type var arg form)
97 "Creates a wrapper around FORM which binds the lisp translation of
98ARG to VAR during a C callback.")
99
100(define-type-generic writer-function (type &key temp inlined)
101 "Returns a function taking a value, an address and an optional
102offset which when called will write a reference an object at the given
103location. If TEMP is non NIL then the object is expected to be valid
104as long as the reference exists.")
105(define-type-generic reader-function (type &key ref inlined)
106 "Returns a function taking an address and optional offset which when
107called will return the object at given location. REF should be :READ,
108:PEEK or :GET")
109(define-type-generic destroy-function (type &key temp inlined)
110 "Returns a function taking an address and optional offset which when
111called will destroy the reference at the given location. This may
112involve freeing the foreign object being referenced or decreasing it's
113ref. count. If TEMP is non NIL then the reference is expected to
114have been written as temporal.")
115(define-type-generic copy-function (type &key inlined))
116
117(define-type-generic unbound-value (type-spec)
118 "Returns a value which should be interpreted as unbound for slots with virtual allocation")
119
120(defun assert-inlined (type inlined-p)
121 (unless inlined-p
122 (error "Type ~A can only be inlined" type)))
123
124(defun assert-not-inlined (type inlined-p)
125 (when inlined-p
126 (error "Type ~A can not be inlined" type)))
127
128
129(define-type-method alien-arg-wrapper ((type t) var arg style form &optional
130 (copy-in-p nil copy-in-given-p))
131 (let ((alien-type (alien-type type)))
132 (cond
133 ((in-arg-p style)
134 (let ((to-alien (if copy-in-given-p
135 (to-alien-form type arg copy-in-p)
136 (to-alien-form type arg))))
137 #+(or cmu sbcl)
138 `(with-alien ((,var ,alien-type ,to-alien))
139 ,form)
140 #+clisp
141 `(ffi:with-c-var (,var ',alien-type ,to-alien)
142 ,form)))
143 ((out-arg-p style)
144 #+(or cmu sbcl)
145 `(with-alien ((,var ,alien-type))
146 (clear-memory (alien-sap (addr ,var)) ,(size-of type))
147 ,form)
148 #+clisp
149 `(ffi:with-c-var (,var ',alien-type)
150 ,form)))))
151
152(define-type-method callback-wrapper ((type t) var arg form)
153 `(let ((,var ,(from-alien-form type arg :ref :temp)))
154 ,form))
155
156(define-type-method alien-type ((type t))
157 (error "No alien type corresponding to the type specifier ~A" type))
158
2c708568 159(define-type-method argument-type ((type t))
160 type)
161
162(define-type-method return-type ((type t))
163 type)
164
beae6579 165(define-type-method to-alien-form ((type t) form &optional copy-p)
166 (declare (ignore form copy-p))
167 (error "Not a valid type specifier for arguments: ~A" type))
168
169(define-type-method to-alien-function ((type t) &optional copy-p)
170 (declare (ignore copy-p))
171 (error "Not a valid type specifier for arguments: ~A" type))
172
173(define-type-method from-alien-form ((type t) form &key ref)
174 (declare (ignore form ref))
175 (error "Not a valid type specifier for return values: ~A" type))
176
177(define-type-method from-alien-function ((type t) &key ref)
178 (declare (ignore ref))
179 (error "Not a valid type specifier for return values: ~A" type))
180
181(define-type-method destroy-function ((type t) &key temp (inlined t inlined-p))
182 (declare (ignore temp))
183 (let ((size (if inlined-p
184 (size-of type :inlined inlined)
185 (size-of type))))
186 #'(lambda (location &optional (offset 0))
187 (clear-memory location size offset))))
188
189(define-type-method copy-function ((type t) &key (inlined t inlined-p))
190 (let ((size (if inlined-p
191 (size-of type :inlined inlined)
192 (size-of type))))
193 #'(lambda (from to &optional (offset 0))
194 (copy-memory (pointer+ from offset) size (pointer+ to offset)))))
195
196(define-type-method to-alien-form ((type real) form &optional copy-p)
197 (declare (ignore type copy-p))
198 form)
199
200(define-type-method to-alien-function ((type real) &optional copy-p)
201 (declare (ignore type copy-p))
202 #'identity)
203
204(define-type-method from-alien-form ((type real) form &key ref)
205 (declare (ignore type ref))
206 form)
207
208(define-type-method from-alien-function ((type real) &key ref)
209 (declare (ignore type ref))
210 #'identity)
211
212
213(define-type-method alien-type ((type integer))
214 (declare (ignore type))
215 (alien-type 'signed-byte))
216
217(define-type-method size-of ((type integer) &key (inlined t))
218 (declare (ignore type))
219 (size-of 'signed-byte :inlined inlined))
220
90e8bbf6 221(define-type-method type-alignment ((type integer) &key (inlined t))
222 (declare (ignore type))
223 (type-alignment 'signed-byte :inlined inlined))
224
beae6579 225(define-type-method writer-function ((type integer) &key temp (inlined t))
226 (declare (ignore temp))
227 (assert-inlined type inlined)
228 (writer-function 'signed-byte))
229
230(define-type-method reader-function ((type integer) &key ref (inlined t))
231 (declare (ignore ref))
232 (assert-inlined type inlined)
233 (reader-function 'signed-byte))
234
235
236;;; Signed Byte
237
238(define-type-method alien-type ((type signed-byte))
239 (destructuring-bind (&optional (size '*))
240 (rest (mklist (type-expand-to 'signed-byte type)))
241 (let ((size (if (eq size '*)
242 (second (type-expand-to 'signed-byte 'int))
243 size)))
244 #+cmu
245 (ecase size
246 ( 8 '(alien:signed 8))
247 (16 '(alien:signed 16))
248 (32 '(alien:signed 32))
249 (64 '(alien:signed 64)))
250 #+sbcl
251 (ecase size
252 ( 8 '(sb-alien:signed 8))
253 (16 '(sb-alien:signed 16))
254 (32 '(sb-alien:signed 32))
255 (64 '(sb-alien:signed 64)))
256 #+clisp
257 (ecase size
258 ( 8 'ffi:sint8)
259 (16 'ffi:sint16)
260 (32 'ffi:sint32)
261 (64 'ffi:sint64)))))
262
263(define-type-method size-of ((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))
269 size)))
270 (ecase size
271 ( 8 1)
272 (16 2)
273 (32 4)
274 (64 8)))))
275
90e8bbf6 276(define-type-method type-alignment ((type signed-byte) &key (inlined t))
277 (assert-inlined type inlined)
278 (destructuring-bind (&optional (size '*))
279 (rest (mklist (type-expand-to 'signed-byte type)))
280 (let ((size (if (eq size '*)
281 (second (type-expand-to 'signed-byte 'int))
282 size)))
283 #+sbcl(sb-alignment `(sb-alien:signed ,size))
284 #+clisp(ecase size
285 ( 8 (nth-value 1 (ffi:sizeof 'ffi:sint8)))
286 (16 (nth-value 1 (ffi:sizeof 'ffi:sint16)))
287 (32 (nth-value 1 (ffi:sizeof 'ffi:sint32)))
288 (64 (nth-value 1 (ffi:sizeof 'ffi:sint64))))
289 #-(or sbcl clisp) 4)))
290
beae6579 291(define-type-method writer-function ((type signed-byte) &key temp (inlined t))
292 (declare (ignore temp))
293 (assert-inlined type inlined)
294 (destructuring-bind (&optional (size '*))
295 (rest (mklist (type-expand-to 'signed-byte type)))
296 (let ((size (if (eq size '*)
297 (second (type-expand-to 'signed-byte 'int))
298 size)))
299 (ecase size
2c708568 300 ( 8 #'(setf ref-int-8))
301 (16 #'(setf ref-native-int-16))
302 (32 #'(setf ref-native-int-32))
303 (64 #'(setf ref-native-int-64))))))
beae6579 304
305(define-type-method reader-function ((type signed-byte) &key ref (inlined t))
306 (declare (ignore ref))
307 (assert-inlined type inlined)
308 (destructuring-bind (&optional (size '*))
309 (rest (mklist (type-expand-to 'signed-byte type)))
310 (let ((size (if (eq size '*)
311 (second (type-expand-to 'signed-byte 'int))
312 size)))
313 (ecase size
2c708568 314 ( 8 #'ref-int-8)
315 (16 #'ref-native-int-16)
316 (32 #'ref-native-int-32)
317 (64 #'ref-native-int-64)))))
beae6579 318
319
320;;; Unsigned Byte
321
322(define-type-method alien-type ((type unsigned-byte))
323 (destructuring-bind (&optional (size '*))
324 (rest (mklist (type-expand-to 'unsigned-byte type)))
325 (let ((size (if (eq size '*)
326 (second (type-expand-to 'signed-byte 'int))
327 size)))
328 #+cmu
329 (ecase size
330 ( 8 '(alien:unsigned 8))
331 (16 '(alien:unsigned 16))
332 (32 '(alien:unsigned 32))
333 (64 '(alien:unsigned 64)))
334 #+sbcl
335 (ecase size
336 ( 8 '(sb-alien:unsigned 8))
337 (16 '(sb-alien:unsigned 16))
338 (32 '(sb-alien:unsigned 32))
339 (64 '(sb-alien:unsigned 64)))
340 #+clisp
341 (ecase size
342 ( 8 'ffi:uint8)
343 (16 'ffi:uint16)
344 (32 'ffi:uint32)
345 (64 'ffi:uint64)))))
346
347(define-type-method size-of ((type unsigned-byte) &key (inlined t))
348 (assert-inlined type inlined)
349 (destructuring-bind (&optional (size '*))
350 (rest (mklist (type-expand-to 'unsigned-byte type)))
351 (size-of `(signed ,size))))
352
90e8bbf6 353(define-type-method type-alignment ((type unsigned-byte) &key (inlined t))
354 (assert-inlined type inlined)
355 (destructuring-bind (&optional (size '*))
356 (rest (mklist (type-expand-to 'unsigned-byte type)))
357 (type-alignment `(signed ,size))))
358
beae6579 359(define-type-method writer-function ((type unsigned-byte) &key temp (inlined t))
360 (declare (ignore temp))
361 (assert-inlined type inlined)
362 (destructuring-bind (&optional (size '*))
363 (rest (mklist (type-expand-to 'unsigned-byte type)))
364 (let ((size (if (eq size '*)
365 (second (type-expand-to 'signed-byte 'int))
366 size)))
367 (ecase size
2c708568 368 ( 8 #'(setf ref-uint-8))
369 (16 #'(setf ref-native-uint-16))
370 (32 #'(setf ref-native-uint-32))
371 (64 #'(setf ref-native-uint-64))))))
beae6579 372
373(define-type-method reader-function ((type unsigned-byte) &key ref (inlined t))
374 (declare (ignore ref))
375 (assert-inlined type inlined)
376 (destructuring-bind (&optional (size '*))
377 (rest (mklist (type-expand-to 'unsigned-byte type)))
378 (let ((size (if (eq size '*)
379 (second (type-expand-to 'signed-byte 'int))
380 size)))
381 (ecase size
2c708568 382 ( 8 #'ref-uint-8)
383 (16 #'ref-native-uint-16)
384 (32 #'ref-native-uint-32)
385 (64 #'ref-native-uint-64)))))
beae6579 386
387
388;;; Single Float
389
390(define-type-method alien-type ((type single-float))
391 (declare (ignore type))
392 #+cmu 'alien:single-float
393 #+sbcl 'sb-alien:single-float
394 #+clisp 'single-float)
395
2c708568 396(define-type-method argument-type ((type single-float))
397 (declare (ignore type))
398 'number)
399
beae6579 400(define-type-method size-of ((type single-float) &key (inlined t))
401 (assert-inlined type inlined)
402 #+sbcl (sb-sizeof 'sb-alien:float)
403 #+clisp (ffi:sizeof 'single-float)
404 #-(or sbcl clisp) 4)
405
90e8bbf6 406(define-type-method type-alignment ((type single-float) &key (inlined t))
407 (assert-inlined type inlined)
408 #+sbcl (sb-alignment 'single-float)
409 #+clisp (nth-value 1 (ffi:sizeof 'single-float))
410 #-(or sbcl clisp) 4)
411
beae6579 412(define-type-method to-alien-form ((type single-float) form &optional copy-p)
413 (declare (ignore type copy-p))
414 `(coerce ,form 'single-float))
415
416(define-type-method to-alien-function ((type single-float) &optional copy-p)
417 (declare (ignore type copy-p))
418 #'(lambda (number)
419 (coerce number 'single-float)))
420
421(define-type-method writer-function ((type single-float) &key temp (inlined t))
422 (declare (ignore temp))
423 (assert-inlined type inlined)
7c14f6ab 424 #'(lambda (number location &optional (offset 0))
2c708568 425 (setf (ref-native-single-float location offset) (coerce number 'single-float))))
beae6579 426
427(define-type-method reader-function ((type single-float) &key ref (inlined t))
428 (declare (ignore ref))
429 (assert-inlined type inlined)
2c708568 430 #'ref-native-single-float)
beae6579 431
432
433
434;;; Double Float
435
436(define-type-method alien-type ((type double-float))
437 (declare (ignore type))
438 #+cmu 'alien:double-float
439 #+sbcl 'sb-alien:double-float
440 #+clisp 'double-float)
441
2c708568 442(define-type-method argument-type ((type double-float))
443 (declare (ignore type))
444 'number)
445
beae6579 446(define-type-method size-of ((type double-float) &key (inlined t))
447 (assert-inlined type inlined)
448 #+sbcl (sb-sizeof 'sb-alien:double)
449 #+clisp (ffi:sizeof 'double-float)
450 #-(or sbcl clisp) 8)
451
90e8bbf6 452(define-type-method type-alignment ((type double-float) &key (inlined t))
453 (assert-inlined type inlined)
454 #+sbcl (sb-alignment 'double-float)
455 #+clisp (nth-value 1 (ffi:sizeof 'double-float))
456 #-(or sbcl clisp) 4)
457
beae6579 458(define-type-method to-alien-form ((type double-float) form &optional copy-p)
459 (declare (ignore type copy-p))
460 `(coerce ,form 'double-float))
461
462(define-type-method to-alien-function ((type double-float) &optional copy-p)
463 (declare (ignore type copy-p))
464 #'(lambda (number)
465 (coerce number 'double-float)))
466
467(define-type-method writer-function ((type double-float) &key temp (inlined t))
468 (declare (ignore temp))
469 (assert-inlined type inlined)
470 #'(lambda (value location &optional (offset 0))
2c708568 471 (setf (ref-native-double-float location offset) (coerce value 'double-float))))
beae6579 472
473(define-type-method reader-function ((type double-float) &key ref (inlined t))
474 (declare (ignore ref))
475 (assert-inlined type inlined)
2c708568 476 #'ref-native-double-float)
beae6579 477
5fa2eaf1 478(deftype optimized-double-float () 'double-float)
479
480(define-type-method to-alien-form ((type optimized-double-float) form &optional copy-p)
481 (declare (ignore type copy-p))
482 form)
483
2c708568 484(define-type-method argument-type ((type optimized-double-float))
485 (declare (ignore type))
486 'double-float)
487
beae6579 488
489
490;;; Character
491
492(define-type-method alien-type ((type base-char))
493 (declare (ignore type))
494 #+cmu 'c-call:char
495 #+sbcl 'sb-alien:char
496 #+clisp 'ffi:character)
497
498(define-type-method size-of ((type base-char) &key (inlined t))
499 (assert-inlined type inlined)
500 1)
90e8bbf6 501
502(define-type-method type-alignment ((type base-char) &key (inlined t))
503 (assert-inlined type inlined)
504 #+sbcl (sb-alignment 'sb-alien:char)
505 #+clisp (nth-value 1 (ffi:sizeof 'ffi:character))
506 #-(or sbcl clisp) 4)
beae6579 507
508(define-type-method to-alien-form ((type base-char) form &optional copy-p)
509 (declare (ignore type copy-p))
510 form)
511
512(define-type-method to-alien-function ((type base-char) &optional copy-p)
513 (declare (ignore type copy-p))
514 #'identity)
515
516(define-type-method from-alien-form ((type base-char) form &key ref)
517 (declare (ignore type ref))
518 form)
519
520(define-type-method from-alien-function ((type base-char) &key ref)
521 (declare (ignore type ref))
522 #'identity)
523
524(define-type-method writer-function ((type base-char) &key temp (inlined t))
525 (declare (ignore temp))
526 (assert-inlined type inlined)
527 #'(lambda (char location &optional (offset 0))
2c708568 528 (setf (ref-int-8 location offset) (char-code char))))
beae6579 529
530(define-type-method reader-function ((type base-char) &key ref (inlined t))
531 (declare (ignore ref))
532 (assert-inlined type inlined)
533 #'(lambda (location &optional (offset 0))
2c708568 534 (code-char (ref-int-8 location offset))))
beae6579 535
536
537
538;;; String
539
540(defun utf8-length (string)
e846072c 541 "Returns the length including the trailing zero, of STRING encoded as UTF8"
beae6579 542 (1+ (loop
543 for char across string
544 as char-code = (char-code char)
545 sum (cond
546 ((< char-code #x7F) 1)
547 ((< char-code #x7FF) 2)
548 ((< char-code #xFFFF) 3)
549 ((< char-code #x1FFFFF) 4)))))
550
551(defun encode-utf8-string (string &optional location)
4be970ba 552 (let* ((len (utf8-length string))
553 (location (or location (allocate-memory len))))
beae6579 554 (loop
555 for char across string
556 for i from 0
557 as char-code = (char-code char)
558 do (flet ((encode (size)
559 (let ((rem (mod size 6)))
2c708568 560 (setf (ref-uint-8 location i)
beae6579 561 (deposit-field
562 #xFF (byte (- 7 rem) (1+ rem))
563 (ldb (byte rem (- size rem)) char-code)))
564 (loop
565 for pos from (- size rem 6) downto 0 by 6
2c708568 566 do (setf (ref-uint-8 location (incf i))
beae6579 567 (+ 128 (ldb (byte 6 pos) char-code)))))))
568 (cond
2c708568 569 ((< char-code #x80) (setf (ref-uint-8 location i) char-code))
beae6579 570 ((< char-code #x800) (encode 11))
571 ((< char-code #x10000) (encode 16))
4be970ba 572 ((< char-code #x200000) (encode 21)))))
2c708568 573 (setf (ref-uint-8 location (1- len)) 0)
beae6579 574 location))
575
576(defun decode-utf8-string (c-string)
577 (with-output-to-string (string)
578 (loop
579 for i from 0
2c708568 580 as octet = (ref-uint-8 c-string i)
beae6579 581 until (zerop octet)
582 do (flet ((decode (size)
583 (loop
584 with rem = (mod size 6)
585 for pos from (- size rem) downto 0 by 6
586 as code = (dpb (ldb (byte rem 0) octet) (byte rem pos) 0)
587 then (dpb
2c708568 588 (ldb (byte 6 0) (ref-uint-8 c-string (incf i)))
beae6579 589 (byte 6 pos) code)
590 finally (write-char (code-char code) string))))
591 (cond
592 ((< octet 128) (write-char (code-char octet) string))
593 ((< octet 224) (decode 11))
594 ((< octet 240) (decode 16))
595 ((< octet 248) (decode 21)))))))
596
597
598(define-type-method alien-arg-wrapper ((type string) var string style form &optional copy-in-p)
599 (declare (ignore type))
600 (cond
601 ((and (in-arg-p style) copy-in-p)
602 `(with-pointer (,var (encode-utf8-string ,string))
603 ,form))
604 ((and (in-arg-p style) (not (out-arg-p style)))
605 `(with-memory (,var (utf8-length ,string))
606 (encode-utf8-string ,string ,var)
607 ,form))
608 ((and (in-arg-p style) (out-arg-p style))
609 (let ((c-string (make-symbol "C-STRING")))
610 `(with-memory (,c-string (utf8-length ,string))
611 (encode-utf8-string ,string ,c-string)
612 (with-pointer (,var ,c-string)
613 ,form))))
614 ((and (out-arg-p style) (not (in-arg-p style)))
615 `(with-pointer (,var)
616 ,form))))
617
618(define-type-method alien-type ((type string))
619 (declare (ignore type))
620 (alien-type 'pointer))
621
2c708568 622(define-type-method argument-type ((type string))
623 'string)
624
625(define-type-method return-type ((type string))
626 'string)
627
beae6579 628(define-type-method size-of ((type string) &key inlined)
629 (assert-not-inlined type inlined)
630 (size-of 'pointer))
631
90e8bbf6 632(define-type-method type-alignment ((type string) &key inlined)
633 (assert-not-inlined type inlined)
634 (type-alignment 'pointer))
635
beae6579 636(define-type-method to-alien-form ((type string) string &optional copy-p)
637 (declare (ignore type copy-p))
638 `(encode-utf8-string ,string))
639
640(define-type-method to-alien-function ((type string) &optional copy-p)
641 (declare (ignore type))
642 (values
643 #'encode-utf8-string
644 (unless copy-p
645 #'(lambda (string c-string)
646 (declare (ignore string))
647 (deallocate-memory c-string)))))
648
649(define-type-method from-alien-form ((type string) form &key (ref :free))
650 (declare (ignore type))
651 `(let ((c-string ,form))
652 (unless (null-pointer-p c-string)
653 (prog1
654 (decode-utf8-string c-string)
655 ,(when (eq ref :free)
656 `(deallocate-memory c-string))))))
657
658(define-type-method from-alien-function ((type string) &key (ref :free))
659 (declare (ignore type))
660 (if (eq ref :free)
661 #'(lambda (c-string)
662 (unless (null-pointer-p c-string)
663 (prog1
664 (decode-utf8-string c-string)
665 (deallocate-memory c-string))))
666 #'(lambda (c-string)
667 (unless (null-pointer-p c-string)
668 (decode-utf8-string c-string)))))
669
670(define-type-method writer-function ((type string) &key temp inlined)
671 (declare (ignore temp))
672 (assert-not-inlined type inlined)
673 #'(lambda (string location &optional (offset 0))
674 (assert (null-pointer-p (ref-pointer location offset)))
675 (setf (ref-pointer location offset) (encode-utf8-string string))))
676
677(define-type-method reader-function ((type string) &key (ref :read) inlined)
678 (assert-not-inlined type inlined)
679 (ecase ref
680 ((:read :peek)
681 #'(lambda (location &optional (offset 0))
682 (unless (null-pointer-p (ref-pointer location offset))
683 (decode-utf8-string (ref-pointer location offset)))))
684 (:get
685 #'(lambda (location &optional (offset 0))
686 (unless (null-pointer-p (ref-pointer location offset))
687 (prog1
688 (decode-utf8-string (ref-pointer location offset))
689 (deallocate-memory (ref-pointer location offset))
690 (setf (ref-pointer location offset) (make-pointer 0))))))))
691
692(define-type-method destroy-function ((type string) &key temp inlined)
693 (declare (ignore temp))
694 (assert-not-inlined type inlined)
695 #'(lambda (location &optional (offset 0))
696 (unless (null-pointer-p (ref-pointer location offset))
697 (deallocate-memory (ref-pointer location offset))
698 (setf (ref-pointer location offset) (make-pointer 0)))))
699
700(define-type-method copy-function ((type string) &key inlined)
701 (assert-not-inlined type inlined)
702 (lambda (from to &optional (offset 0))
703 (let* ((string (ref-pointer from offset))
704 (length (loop
705 for i from 0
2c708568 706 until (zerop (ref-uint-8 string i))
beae6579 707 finally (return (1+ i)))))
708 (setf (ref-pointer to offset) (copy-memory string length)))))
709
710(define-type-method unbound-value ((type string))
711 (declare (ignore type))
712 nil)
713
714
715
716;;; Pathname
717
718(define-type-method alien-type ((type pathname))
719 (declare (ignore type))
720 (alien-type 'string))
721
2c708568 722(define-type-method argument-type ((type pathname))
723 (declare (ignore type))
724 '(or pathname string))
725
beae6579 726(define-type-method size-of ((type pathname) &key inlined)
727 (assert-not-inlined type inlined)
728 (size-of 'string))
729
90e8bbf6 730(define-type-method type-alignment ((type pathname) &key inlined)
731 (assert-not-inlined type inlined)
732 (type-alignment 'string))
733
beae6579 734(define-type-method alien-arg-wrapper ((type pathname) var pathname style form &optional copy-in-p)
735 (declare (ignore type))
736 (alien-arg-wrapper 'string var `(namestring (translate-logical-pathname ,pathname)) style form copy-in-p))
737
738(define-type-method to-alien-form ((type pathname) path)
739 (declare (ignore type))
740 (to-alien-form 'string `(namestring (translate-logical-pathname ,path))))
741
742(define-type-method to-alien-function ((type pathname) &optional copy-p)
743 (declare (ignore type))
744 (let ((string-function (to-alien-function 'string copy-p)))
745 #'(lambda (path)
746 (funcall string-function (namestring path)))))
747
748(define-type-method from-alien-form ((type pathname) form &key (ref :free))
749 (declare (ignore type))
750 `(parse-namestring ,(from-alien-form 'string form :ref ref)))
751
752(define-type-method from-alien-function ((type pathname) &key (ref :free))
753 (declare (ignore type))
754 (let ((string-function (from-alien-function 'string :ref ref)))
755 #'(lambda (string)
756 (parse-namestring (funcall string-function string)))))
757
758(define-type-method writer-function ((type pathname) &key temp inlined)
759 (declare (ignore temp))
760 (assert-not-inlined type inlined)
761 (let ((string-writer (writer-function 'string)))
762 #'(lambda (path location &optional (offset 0))
763 (funcall string-writer (namestring path) location offset))))
764
765(define-type-method reader-function ((type pathname) &key ref inlined)
766 (declare (ignore ref))
767 (assert-not-inlined type inlined)
768 (let ((string-reader (reader-function 'string)))
769 #'(lambda (location &optional (offset 0))
770 (let ((string (funcall string-reader location offset)))
771 (when string
772 (parse-namestring string))))))
773
774(define-type-method destroy-function ((type pathname) &key temp inlined)
775 (declare (ignore temp))
776 (assert-not-inlined type inlined)
777 (destroy-function 'string))
778
779(define-type-method copy-function ((type pathname) &key inlined)
780 (assert-not-inlined type inlined)
781 (copy-function 'string))
782
783(define-type-method unbound-value ((type pathname))
784 (declare (ignore type))
785 (unbound-value 'string))
786
787
788
789;;; Bool
790
791(define-type-method alien-type ((type bool))
792 (destructuring-bind (&optional (size '*))
793 (rest (mklist (type-expand-to 'bool type)))
794 (alien-type `(signed-byte ,size))))
795
796(define-type-method size-of ((type bool) &key (inlined t))
797 (assert-inlined type inlined)
798 (destructuring-bind (&optional (size '*))
799 (rest (mklist (type-expand-to 'bool type)))
800 (size-of `(signed-byte ,size))))
801
90e8bbf6 802(define-type-method type-alignment ((type bool) &key (inlined t))
803 (assert-inlined type inlined)
804 (destructuring-bind (&optional (size '*))
805 (rest (mklist (type-expand-to 'bool type)))
806 (type-alignment `(signed-byte ,size))))
807
beae6579 808(define-type-method to-alien-form ((type bool) bool &optional copy-p)
809 (declare (ignore type copy-p))
810 `(if ,bool 1 0))
811
812(define-type-method to-alien-function ((type bool) &optional copy-p)
813 (declare (ignore type copy-p))
814 #'(lambda (bool)
815 (if bool 1 0)))
816
817(define-type-method from-alien-form ((type bool) form &key ref)
818 (declare (ignore type ref))
819 `(not (zerop ,form)))
820
821(define-type-method from-alien-function ((type bool) &key ref)
822 (declare (ignore type ref))
823 #'(lambda (bool)
824 (not (zerop bool))))
825
826(define-type-method writer-function ((type bool) &key temp (inlined t))
827 (declare (ignore temp))
828 (assert-inlined type inlined)
829 (destructuring-bind (&optional (size '*))
830 (rest (mklist (type-expand-to 'bool type)))
831 (let ((writer (writer-function `(signed-byte ,size))))
832 #'(lambda (bool location &optional (offset 0))
833 (funcall writer (if bool 1 0) location offset)))))
834
835(define-type-method reader-function ((type bool) &key ref (inlined t))
836 (declare (ignore ref))
837 (assert-inlined type inlined)
838 (destructuring-bind (&optional (size '*))
839 (rest (mklist (type-expand-to 'bool type)))
840 (let ((reader (reader-function `(signed-byte ,size))))
841 #'(lambda (location &optional (offset 0))
842 (not (zerop (funcall reader location offset)))))))
843
844
845
846;;; Boolean
847
848(define-type-method alien-type ((type boolean))
849 (declare (ignore type))
850 (alien-type 'bool))
851
2c708568 852(define-type-method argument-type ((type boolean))
853 (declare (ignore type))
854 t)
855
beae6579 856(define-type-method size-of ((type boolean) &key (inlined t))
857 (assert-inlined type inlined)
858 (size-of 'bool))
859
90e8bbf6 860(define-type-method type-alignment ((type boolean) &key (inlined t))
861 (assert-inlined type inlined)
862 (type-alignment 'bool))
863
beae6579 864(define-type-method to-alien-form ((type boolean) boolean &optional copy-p)
865 (declare (ignore type copy-p))
866 (to-alien-form 'bool boolean))
867
868(define-type-method to-alien-function ((type boolean) &optional copy-p)
869 (declare (ignore type copy-p))
870 (to-alien-function 'bool))
871
872(define-type-method from-alien-form ((type boolean) form &key ref)
873 (declare (ignore type ref))
874 (from-alien-form 'bool form))
875
876(define-type-method from-alien-function ((type boolean) &key ref)
877 (declare (ignore type ref))
878 (from-alien-function 'bool))
879
880(define-type-method writer-function ((type boolean) &key temp (inlined t))
881 (declare (ignore temp))
882 (assert-inlined type inlined)
883 (writer-function 'bool))
884
885(define-type-method reader-function ((type boolean) &key ref (inlined t))
886 (declare (ignore ref))
887 (assert-inlined type inlined)
888 (reader-function 'bool))
889
890
891;;; Or
892
893(define-type-method alien-type ((type or))
894 (let* ((expanded-type (type-expand-to 'or type))
895 (alien-type (alien-type (second expanded-type))))
896 (unless (every #'(lambda (type)
897 (eq alien-type (alien-type type)))
898 (cddr expanded-type))
899 (error "No common alien type specifier for union type: ~A" type))
900 alien-type))
901
2c708568 902(define-type-method argument-type ((type or))
903 (let ((expanded-type (type-expand-to 'or type)))
904 `(or ,@(mapcar #'argument-type (rest expanded-type)))))
905
906
beae6579 907(define-type-method size-of ((type or) &key (inlined nil inlined-p))
908 (loop
e5214c13 909 for subtype in (cdr (type-expand-to 'or type))
beae6579 910 maximize (if inlined-p
e5214c13 911 (size-of subtype :inlined inlined)
beae6579 912 (size-of subtype))))
913
90e8bbf6 914(define-type-method type-alignment ((type or) &key (inlined nil inlined-p))
915 (loop
e5214c13 916 for subtype in (cdr (type-expand-to 'or type))
90e8bbf6 917 maximize (if inlined-p
e5214c13 918 (type-alignment subtype :inlined inlined)
90e8bbf6 919 (type-alignment subtype))))
920
beae6579 921(define-type-method alien-arg-wrapper ((type or) var value style form &optional copy-in-p)
922 (cond
923 ((and (in-arg-p style) (out-arg-p style))
924 `(etypecase ,value
925 ,@(mapcar
926 #'(lambda (type)
927 `(,type ,(alien-arg-wrapper type var value style form copy-in-p)))
928 (rest (type-expand-to 'or type)))))
929 ((in-arg-p style)
2c708568 930 ;; If the unexpanded type has explicit alien-type and
931 ;; to-alien-form methods, we just call the default arg wrapper
932 (if (and
933 (not (eq (first (mklist type)) 'or))
934 (find-type-method 'alien-type type nil)
935 (find-type-method 'to-alien-form type nil))
936 (funcall (find-type-method 'alien-arg-wrapper t) type var value style form copy-in-p)
937 (let ((body (make-symbol "BODY")))
938 `(flet ((,body (,var)
939 ,form))
940 (etypecase ,value
941 ,@(mapcar
942 #'(lambda (type)
943 `(,type ,(alien-arg-wrapper type var value style `(,body ,var) copy-in-p)))
944 (rest (type-expand-to 'or type))))))))
beae6579 945 ((out-arg-p style)
946 #+(or cmu sbcl)
947 `(with-alien ((,var ,(alien-type type)))
948 (clear-memory (alien-sap (addr ,var)) ,(size-of type))
949 ,form)
950 #+clisp
951 `(ffi:with-c-var (,var ',(alien-type type))
952 ,form))))
953
954(define-type-method to-alien-form ((type or) form &optional copy-p)
955 `(let ((value ,form))
956 (etypecase value
957 ,@(mapcar
958 #'(lambda (type)
959 `(,type ,(to-alien-form type 'value copy-p)))
960 (rest (type-expand-to 'or type))))))
961
962(define-type-method to-alien-function ((type or) &optional copy-p)
963 (let* ((expanded-type (type-expand-to 'or type))
964 (functions (loop
965 for type in (rest expanded-type)
966 collect (to-alien-function type copy-p))))
967 #'(lambda (value)
968 (loop
969 for function in functions
970 for alt-type in (rest expanded-type)
971 when (typep value alt-type)
972 do (return (funcall function value))
973 finally (error "~S is not of type ~A" value type)))))
974
975
976;;; Pointer
977
978(define-type-method alien-type ((type pointer))
979 (declare (ignore type))
980 #+(or cmu sbcl) 'system-area-pointer
981 #+clisp 'ffi:c-pointer)
982
983(define-type-method size-of ((type pointer) &key (inlined t))
984 (assert-inlined type inlined)
985 #+sbcl (sb-sizeof 'sb-alien:system-area-pointer)
986 #+clisp (ffi:sizeof 'ffi:c-pointer)
987 #-(or sbcl clisp) 4)
988
90e8bbf6 989(define-type-method type-alignment ((type pointer) &key (inlined t))
990 (assert-inlined type inlined)
991 #+sbcl (sb-alignment 'system-area-pointer)
992 #+clisp (ffi:sizeof 'ffi:c-pointer)
993 #-(or sbcl clisp) (size-of 'pointer))
994
beae6579 995(define-type-method to-alien-form ((type pointer) form &optional copy-p)
996 (declare (ignore type copy-p))
997 form)
998
999(define-type-method to-alien-function ((type pointer) &optional copy-p)
1000 (declare (ignore type copy-p))
1001 #'identity)
1002
1003(define-type-method from-alien-form ((type pointer) form &key ref)
1004 (declare (ignore type ref))
1005 form)
1006
1007(define-type-method from-alien-function ((type pointer) &key ref)
1008 (declare (ignore type ref))
1009 #'identity)
1010
1011(define-type-method writer-function ((type pointer) &key temp (inlined t))
1012 (declare (ignore temp))
1013 (assert-inlined type inlined)
1014 #'(setf ref-pointer))
1015
1016(define-type-method reader-function ((type pointer) &key ref (inlined t))
1017 (declare (ignore ref))
1018 (assert-inlined type inlined)
1019 #'ref-pointer)
1020
1021
1022(define-type-method alien-type ((type null))
1023 (declare (ignore type))
1024 (alien-type 'pointer))
1025
1026(define-type-method size-of ((type null) &key (inlined t))
1027 (assert-inlined type inlined)
1028 (size-of 'pointer))
1029
1030(define-type-method to-alien-form ((type null) null &optional copy-p)
1031 (declare (ignore type copy-p))
1032 `(progn ,null (make-pointer 0)))
1033
1034(define-type-method to-alien-function ((type null) &optional copy-p)
1035 (declare (ignore type copy-p))
1036 #'(lambda (null)
1037 (declare (ignore null))
1038 (make-pointer 0)))
1039
1040
1041(define-type-method alien-type ((type nil))
1042 (declare (ignore type))
1043 #+(or cmu sbcl) 'void
1044 #+clisp nil)
1045
1046(define-type-method from-alien-form ((type nil) form &key ref)
1047 (declare (ignore type ref))
1048 form)
1049
1050(define-type-method from-alien-function ((type nil) &key ref)
1051 (declare (ignore type ref))
1052 #'(lambda (value)
1053 (declare (ignore value))
1054 (values)))
1055
1056(define-type-method to-alien-form ((type nil) form &optional copy-p)
1057 (declare (ignore type copy-p))
1058 form)
1059
1060
1061
1062;;; Callbacks
1063
1064(define-type-method alien-type ((type callback))
1065 (declare (ignore type))
1066 (alien-type 'pointer))
1067
1068(define-type-method to-alien-form ((type callback) callback &optional copy-p)
1069 (declare (ignore type copy-p))
1070 `(callback-address ,callback))
1071
1072
1073
1074;;; Copy-of
1075
2c708568 1076(define-type-method return-type ((type copy-of))
1077 (return-type (second type)))
1078
beae6579 1079(define-type-method from-alien-form ((type copy-of) form &key (ref :copy))
1080 (if (eq ref :copy)
1081 (from-alien-form (second (type-expand-to 'copy-of type)) form :ref ref)
1082 (error "Keyword arg :REF to FROM-ALIEN-FORM should be :COPY for type ~A. It was give ~A" type ref)))
1083
1084(define-type-method from-alien-function ((type copy-of) &key (ref :copy))
1085 (if (eq ref :copy)
1086 (from-alien-function (second (type-expand-to 'copy-of type)) :ref ref)
ea96309c 1087 (error "Keyword arg :REF to FROM-ALIEN-FUNCTION should be :COPY for type ~A. It was give ~A" type ref)))
beae6579 1088
1089(define-type-method to-alien-form ((type copy-of) form &optional (copy-p t))
1090 (if copy-p
1091 (to-alien-form (second (type-expand-to 'copy-of type)) form t)
1092 (error "COPY-P argument to TO-ALIEN-FORM should always be non NIL for type ~A" type)))
1093
1094(define-type-method to-alien-function ((type copy-of) &optional (copy-p t))
1095 (if copy-p
1096 (to-alien-function (second (type-expand-to 'copy-of type)) t)
1097 (error "COPY-P argument to TO-ALIEN-FUNCTION should always be non NIL for type ~A" type)))
1098
1099(define-type-method reader-function ((type copy-of) &key (ref :read) (inlined nil inlined-p))
1100 (if inlined-p
1101 (reader-function (second (type-expand-to 'copy-of type))
1102 :ref (if (eq ref :get) :read ref) :inlined inlined)
1103 (reader-function (second (type-expand-to 'copy-of type))
1104 :ref (if (eq ref :get) :read ref))))
1105
1106(define-type-method destroy-function ((type copy-of) &key temp inlined)
1107 (declare (ignore type temp inlined))
1108 #'(lambda (location &optional offset)
1109 (declare (ignore location offset))))
1110
1111(define-type-method copy-function ((type copy-of) &key (inlined nil inlined-p))
1112 (let ((size (if inlined-p
1113 (size-of type :inlined inlined)
1114 (size-of type))))
1115 #'(lambda (from to &optional (offset 0))
1116 (copy-memory (pointer+ from offset) size (pointer+ to offset)))))
1117
1118
1119
1120;;; Static
1121
2c708568 1122(define-type-method return-type ((type static))
1123 (return-type (second type)))
1124
beae6579 1125(define-type-method from-alien-form ((type static) form &key (ref :static))
1126 (if (eq ref :static)
1127 (from-alien-form (second (type-expand-to 'static type)) form :ref ref)
1128 (error "Keyword arg :REF to FROM-ALIEN-FORM should be :STATIC for type ~A. It was give ~A" type ref)))
1129
1130(define-type-method from-alien-function ((type static) &key (ref :static))
1131 (if (eq ref :static)
1132 (from-alien-function (second (type-expand-to 'static type)) :ref ref)
ea96309c 1133 (error "Keyword arg :REF to FROM-ALIEN-FUNCTION should be :STATIC for type ~A. It was give ~A" type ref)))
beae6579 1134
1135(define-type-method to-alien-function ((type static) &optional copy-p)
1136 (if (not copy-p)
1137 (to-alien-function (second (type-expand-to 'static type)) t)
c4261a5c 1138 (error "COPY-P argument to TO-ALIEN-FUNCTION should always be NIL for type ~A" type)))
beae6579 1139
1140(define-type-method to-alien-form ((type static) &optional copy-p)
1141 (if (not copy-p)
c4261a5c 1142 (to-alien-form (second (type-expand-to 'static type)) t)
1143 (error "COPY-P argument to TO-ALIEN-FORM should always be NIL for type ~A" type)))
beae6579 1144
1145(define-type-method reader-function ((type static) &key (ref :read) (inlined nil inlined-p))
1146 (if inlined-p
1147 (reader-function (second (type-expand-to 'static type))
1148 :ref (if (eq ref :get) :read ref) :inlined inlined)
1149 (reader-function (second (type-expand-to 'static type))
1150 :ref (if (eq ref :get) :read ref))))
1151
1152(define-type-method writer-function ((type static) &key temp inlined)
1153 (declare (ignore type temp inlined))
1154 (error "Can't overwrite a static (const) reference"))
1155
1156(define-type-method destroy-function ((type static) &key temp inlined)
1157 (declare (ignore type temp inlined))
1158 #'(lambda (location &optional offset)
1159 (declare (ignore location offset))))
1160
1161(define-type-method copy-function ((type static) &key (inlined nil inlined-p))
1162 (let ((size (if inlined-p
1163 (size-of type :inlined inlined)
1164 (size-of type))))
1165 #'(lambda (from to &optional (offset 0))
1166 (copy-memory (pointer+ from offset) size (pointer+ to offset)))))
1167
1168
1169
1170;;; Pseudo type for inlining of types which are not inlined by default
1171
1172(define-type-method size-of ((type inlined) &key (inlined t))
1173 (assert-inlined type inlined)
1174 (size-of (second (type-expand-to 'inlined type)) :inlined t))
1175
2c708568 1176(define-type-method return-type ((type inlined))
1177 (return-type (second type)))
1178
90e8bbf6 1179(define-type-method type-alignment ((type inlined) &key (inlined t))
1180 (assert-inlined type inlined)
1181 (type-alignment (second (type-expand-to 'inlined type)) :inlined t))
1182
beae6579 1183(define-type-method reader-function ((type inlined) &key (ref :read) (inlined t))
1184 (assert-inlined type inlined)
1185 (reader-function (second (type-expand-to 'inlined type)) :ref ref :inlined t))
1186
1187(define-type-method writer-function ((type inlined) &key temp (inlined t))
1188 (assert-inlined type inlined)
1189 (writer-function (second (type-expand-to 'inlined type)) :temp temp :inlined t))
1190
1191(define-type-method destroy-function ((type inlined) &key temp (inlined t))
1192 (assert-inlined type inlined)
1193 (destroy-function (second (type-expand-to 'inlined type)) :temp temp :inlined t))
1194
1195(define-type-method copy-function ((type inlined) &key (inlined t))
1196 (assert-inlined type inlined)
1197 (copy-function (second (type-expand-to 'inlined type)) :inlined t))