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