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