1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
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.
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.
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
18 ;; $Id: ffi.lisp,v 1.17 2005/02/25 23:55:06 espen Exp $
23 ;;;; Foreign function call interface
25 (defvar *package-prefix* nil)
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*))
33 (defun package-prefix (&optional (package *package*))
34 (let ((package (find-package package)))
36 (cdr (assoc package *package-prefix*))
37 (substitute #\_ #\- (string-downcase (package-name package))))))
39 (defun find-prefix-package (prefix)
41 (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=))
42 (find-package (string-upcase prefix))))
44 (defmacro use-prefix (prefix &optional (package *package*))
45 `(eval-when (:compile-toplevel :load-toplevel :execute)
46 (set-package-prefix ,prefix ,package)))
49 (defun default-alien-fname (lisp-name)
50 (let* ((name (substitute #\_ #\- (string-downcase lisp-name)))
54 (char= (char name 0) #\%)
55 (string= "_p" name :start2 (- (length name) 2)))
56 (subseq name 1 (- (length name) 2)))
57 ((char= (char name 0) #\%)
59 ((string= "_p" name :start2 (- (length name) 2))
60 (subseq name 0 (- (length name) 2)))
62 (prefix (package-prefix *package*)))
63 (if (or (not prefix) (string= prefix ""))
65 (format nil "~A_~A" prefix stripped-name))))
67 (defun default-alien-type-name (type-name)
68 (let ((prefix (package-prefix *package*)))
74 (cons prefix (split-string (symbol-name type-name) #\-))))))
76 (defun default-type-name (alien-name)
80 (split-string-if alien-name #'upper-case-p))))
83 (rest parts) #\-) (find-prefix-package (first parts)))))
86 (defmacro defbinding (name lambda-list return-type &rest docs/args)
87 (multiple-value-bind (lisp-name c-name)
89 (values name (default-alien-fname name))
92 (let ((supplied-lambda-list lambda-list)
95 (dolist (doc/arg docs/args)
99 (destructuring-bind (expr type &optional (style :in)) doc/arg
100 (unless (member style '(:in :out :in-out :return))
101 (error "Bogus argument style ~S in ~S." style doc/arg))
103 (not supplied-lambda-list)
104 (namep expr) (member style '(:in :in-out :return)))
105 (push expr lambda-list))
107 ((and (namep expr) (eq style :out)) expr)
108 ((namep expr) (make-symbol (string expr)))
110 expr (mklist type) style) args)))))
113 c-name lisp-name (or supplied-lambda-list (nreverse lambda-list))
114 return-type (reverse docs) (reverse args)))))
117 (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args)
118 (collect ((alien-types) (alien-bindings) (alien-parameters)
119 (return-values) (cleanup-forms))
121 (destructuring-bind (var expr type style) arg
122 (let ((declaration (alien-type type))
123 (cleanup (cleanup-form var type)))
126 ((member style '(:out :in-out))
127 (alien-types `(* ,declaration))
128 (alien-parameters `(addr ,var))
132 ((eq style :in-out) (list (to-alien-form expr type)))
133 ((eq declaration 'system-area-pointer)
134 (list '(make-pointer 0))))))
135 (return-values (from-alien-form var type)))
137 (alien-types declaration)
139 `(,var ,declaration ,(to-alien-form expr type)))
140 (alien-parameters var)
141 (return-values (from-alien-form var type)))
143 (alien-types declaration)
145 `(,var ,declaration ,(to-alien-form expr type)))
146 (alien-parameters var)
147 (cleanup-forms cleanup))
149 (alien-types declaration)
150 (alien-parameters (to-alien-form expr type)))))))
152 (let* ((alien-name (make-symbol (string lisp-name)))
153 (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters))))
154 `(defun ,lisp-name ,lambda-list
156 #+cmu(declare (optimize (inhibit-warnings 3)))
157 #+sbcl(declare (muffle-conditions compiler-note))
158 (with-alien ((,alien-name
160 ,(alien-type return-type)
162 :extern ,foreign-name)
167 ,(from-alien-form alien-funcall return-type)
174 (values ,@(return-values)))))))))
177 ;;; Creates bindings at runtime
178 (defun mkbinding (name return-type &rest arg-types)
179 #+cmu(declare (optimize (inhibit-warnings 3)))
180 #+sbcl(declare (muffle-conditions compiler-note))
182 `(function ,@(mapcar #'alien-type (cons return-type arg-types))))
185 (make-heap-alien-info
186 :type (parse-alien-type ftype #+sbcl nil)
187 :sap-form (foreign-symbol-address name))))
188 (translate-arguments (mapcar #'to-alien-function arg-types))
189 (translate-return-value (from-alien-function return-type))
190 (cleanup-arguments (mapcar #'cleanup-function arg-types)))
192 #'(lambda (&rest args)
193 (map-into args #'funcall translate-arguments args)
195 (funcall translate-return-value
196 (apply #'alien-funcall alien args))
197 (mapc #'funcall cleanup-arguments args)))))
200 (defmacro defcallback (name (return-type &rest args) &body body)
201 (let ((def-callback #+cmu'alien:def-callback
202 #+sbcl'sb-alien:define-alien-function))
203 `(,def-callback ,name
204 (,(alien-type return-type)
205 ,@(mapcar #'(lambda (arg)
206 (destructuring-bind (name type) arg
207 `(,name ,(alien-type type))))
210 `(let (,@(mapcar #'(lambda (arg)
211 (destructuring-bind (name type) arg
212 `(,name ,(from-alien-form name type))))
219 (sb-alien:alien-function-sap af))
222 ;;;; Definitons and translations of fundamental types
224 (defmacro def-type-method (name args &optional documentation)
226 (defgeneric ,name (,@args type &rest args)
227 ,@(when documentation `((:documentation ,documentation))))
228 (defmethod ,name (,@args (type symbol) &rest args)
229 (let ((class (find-class type nil)))
231 (apply #',name ,@args class args)
232 (multiple-value-bind (super-type expanded-p)
233 (type-expand-1 (cons type args))
235 (,name ,@args super-type)
236 (call-next-method))))))
237 (defmethod ,name (,@args (type cons) &rest args)
238 (declare (ignore args))
239 (apply #',name ,@args (first type) (rest type)))))
242 (def-type-method alien-type ())
243 (def-type-method size-of ())
244 (def-type-method to-alien-form (form))
245 (def-type-method from-alien-form (form))
246 (def-type-method cleanup-form (form)
247 "Creates a form to clean up after the alien call has finished.")
249 (def-type-method to-alien-function ())
250 (def-type-method from-alien-function ())
251 (def-type-method cleanup-function ())
253 (def-type-method copy-to-alien-form (form))
254 (def-type-method copy-to-alien-function ())
255 (def-type-method copy-from-alien-form (form))
256 (def-type-method copy-from-alien-function ())
258 (def-type-method writer-function ())
259 (def-type-method reader-function ())
260 (def-type-method destroy-function ())
262 (def-type-method unbound-value ()
263 "First return value is true if the type has an unbound value, second return value is the actual unbound value")
266 ;; Sizes of fundamental C types in bytes (8 bits)
267 (defconstant +size-of-short+ 2)
268 (defconstant +size-of-int+ 4)
269 (defconstant +size-of-long+ 4)
270 (defconstant +size-of-pointer+ 4)
271 (defconstant +size-of-float+ 4)
272 (defconstant +size-of-double+ 8)
274 ;; Sizes of fundamental C types in bits
275 (defconstant +bits-of-byte+ 8)
276 (defconstant +bits-of-short+ 16)
277 (defconstant +bits-of-int+ 32)
278 (defconstant +bits-of-long+ 32)
281 (deftype int () '(signed-byte #.+bits-of-int+))
282 (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+))
283 (deftype long () '(signed-byte #.+bits-of-long+))
284 (deftype unsigned-long () '(unsigned-byte #.+bits-of-long+))
285 (deftype short () '(signed-byte #.+bits-of-short+))
286 (deftype unsigned-short () '(unsigned-byte #.+bits-of-short+))
287 (deftype signed (&optional (size '*)) `(signed-byte ,size))
288 (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
289 (deftype char () 'base-char)
290 (deftype pointer () 'system-area-pointer)
291 (deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil))
292 ;(deftype invalid () nil)
295 (defmethod to-alien-form (form (type t) &rest args)
296 (declare (ignore type args))
299 (defmethod to-alien-function ((type t) &rest args)
300 (declare (ignore type args))
303 (defmethod from-alien-form (form (type t) &rest args)
304 (declare (ignore type args))
307 (defmethod from-alien-function ((type t) &rest args)
308 (declare (ignore type args))
311 (defmethod cleanup-form (form (type t) &rest args)
312 (declare (ignore form type args))
315 (defmethod cleanup-function ((type t) &rest args)
316 (declare (ignore type args))
319 (defmethod destroy-function ((type t) &rest args)
320 (declare (ignore type args))
321 #'(lambda (location &optional offset)
322 (declare (ignore location offset))))
324 (defmethod copy-to-alien-form (form (type t) &rest args)
325 (apply #'to-alien-form form type args))
327 (defmethod copy-to-alien-function ((type t) &rest args)
328 (apply #'to-alien-function type args))
330 (defmethod copy-from-alien-form (form (type t) &rest args)
331 (apply #'from-alien-form form type args))
333 (defmethod copy-from-alien-function ((type t) &rest args)
334 (apply #'from-alien-function type args))
337 (defmethod alien-type ((type (eql 'signed-byte)) &rest args)
338 (declare (ignore type))
339 (destructuring-bind (&optional (size '*)) args
341 (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8))
342 (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short)
343 ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int)
344 (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long))))
346 (defmethod size-of ((type (eql 'signed-byte)) &rest args)
347 (declare (ignore type))
348 (destructuring-bind (&optional (size '*)) args
351 (#.+bits-of-short+ +size-of-short+)
352 ((* #.+bits-of-int+) +size-of-int+)
353 (#.+bits-of-long+ +size-of-long+))))
355 (defmethod unbound-value ((type t) &rest args)
356 (declare (ignore type args))
359 (defmethod writer-function ((type (eql 'signed-byte)) &rest args)
360 (declare (ignore type))
361 (destructuring-bind (&optional (size '*)) args
362 (let ((size (if (eq size '*) +bits-of-int+ size)))
364 (8 #'(lambda (value location &optional (offset 0))
365 (setf (signed-sap-ref-8 location offset) value)))
366 (16 #'(lambda (value location &optional (offset 0))
367 (setf (signed-sap-ref-16 location offset) value)))
368 (32 #'(lambda (value location &optional (offset 0))
369 (setf (signed-sap-ref-32 location offset) value)))
370 (64 #'(lambda (value location &optional (offset 0))
371 (setf (signed-sap-ref-64 location offset) value)))))))
373 (defmethod reader-function ((type (eql 'signed-byte)) &rest args)
374 (declare (ignore type))
375 (destructuring-bind (&optional (size '*)) args
376 (let ((size (if (eq size '*) +bits-of-int+ size)))
378 (8 #'(lambda (sap &optional (offset 0))
379 (signed-sap-ref-8 sap offset)))
380 (16 #'(lambda (sap &optional (offset 0))
381 (signed-sap-ref-16 sap offset)))
382 (32 #'(lambda (sap &optional (offset 0))
383 (signed-sap-ref-32 sap offset)))
384 (64 #'(lambda (sap &optional (offset 0))
385 (signed-sap-ref-64 sap offset)))))))
387 (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)
388 (destructuring-bind (&optional (size '*)) args
390 (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8))
391 (#.+bits-of-short+ #+cmu 'c-call:unsigned-short
392 #+sbcl 'sb-alien:unsigned-short)
393 ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int
394 #+sbcl 'sb-alien:unsigned-int)
395 (#.+bits-of-long+ #+cmu 'c-call:unsigned-long
396 #+sbcl 'sb-alien:unsigned-long))))
398 (defmethod size-of ((type (eql 'unsigned-byte)) &rest args)
399 (apply #'size-of 'signed args))
401 (defmethod writer-function ((type (eql 'unsigned-byte)) &rest args)
402 (declare (ignore type))
403 (destructuring-bind (&optional (size '*)) args
404 (let ((size (if (eq size '*) +bits-of-int+ size)))
406 (8 #'(lambda (value location &optional (offset 0))
407 (setf (sap-ref-8 location offset) value)))
408 (16 #'(lambda (value location &optional (offset 0))
409 (setf (sap-ref-16 location offset) value)))
410 (32 #'(lambda (value location &optional (offset 0))
411 (setf (sap-ref-32 location offset) value)))
412 (64 #'(lambda (value location &optional (offset 0))
413 (setf (sap-ref-64 location offset) value)))))))
415 (defmethod reader-function ((type (eql 'unsigned-byte)) &rest args)
416 (declare (ignore type))
417 (destructuring-bind (&optional (size '*)) args
418 (let ((size (if (eq size '*) +bits-of-int+ size)))
420 (8 #'(lambda (sap &optional (offset 0))
421 (sap-ref-8 sap offset)))
422 (16 #'(lambda (sap &optional (offset 0))
423 (sap-ref-16 sap offset)))
424 (32 #'(lambda (sap &optional (offset 0))
425 (sap-ref-32 sap offset)))
426 (64 #'(lambda (sap &optional (offset 0))
427 (sap-ref-64 sap offset)))))))
430 (defmethod alien-type ((type (eql 'integer)) &rest args)
431 (declare (ignore type args))
432 (alien-type 'signed-byte))
434 (defmethod size-of ((type (eql 'integer)) &rest args)
435 (declare (ignore type args))
436 (size-of 'signed-byte))
438 (defmethod writer-function ((type (eql 'integer)) &rest args)
439 (declare (ignore type args))
440 (writer-function 'signed-byte))
442 (defmethod reader-function ((type (eql 'integer)) &rest args)
443 (declare (ignore type args))
444 (reader-function 'signed-byte))
447 (defmethod alien-type ((type (eql 'fixnum)) &rest args)
448 (declare (ignore type args))
449 (alien-type 'signed-byte))
451 (defmethod size-of ((type (eql 'fixnum)) &rest args)
452 (declare (ignore type args))
453 (size-of 'signed-byte))
456 (defmethod alien-type ((type (eql 'single-float)) &rest args)
457 (declare (ignore type args))
458 #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float)
460 (defmethod size-of ((type (eql 'single-float)) &rest args)
461 (declare (ignore type args))
464 (defmethod to-alien-form (form (type (eql 'single-float)) &rest args)
465 (declare (ignore type args))
466 `(coerce ,form 'single-float))
468 (defmethod to-alien-function ((type (eql 'single-float)) &rest args)
469 (declare (ignore type args))
471 (coerce number 'single-float)))
473 (defmethod writer-function ((type (eql 'single-float)) &rest args)
474 (declare (ignore type args))
475 #'(lambda (value location &optional (offset 0))
476 (setf (sap-ref-single location offset) (coerce value 'single-float))))
478 (defmethod reader-function ((type (eql 'single-float)) &rest args)
479 (declare (ignore type args))
480 #'(lambda (sap &optional (offset 0))
481 (sap-ref-single sap offset)))
484 (defmethod alien-type ((type (eql 'double-float)) &rest args)
485 (declare (ignore type args))
486 #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float)
488 (defmethod size-of ((type (eql 'double-float)) &rest args)
489 (declare (ignore type args))
492 (defmethod to-alien-form (form (type (eql 'double-float)) &rest args)
493 (declare (ignore type args))
494 `(coerce ,form 'double-float))
496 (defmethod to-alien-function ((type (eql 'double-float)) &rest args)
497 (declare (ignore type args))
499 (coerce number 'double-float)))
501 (defmethod writer-function ((type (eql 'double-float)) &rest args)
502 (declare (ignore type args))
503 #'(lambda (value location &optional (offset 0))
504 (setf (sap-ref-double location offset) (coerce value 'double-float))))
506 (defmethod reader-function ((type (eql 'double-float)) &rest args)
507 (declare (ignore type args))
508 #'(lambda (sap &optional (offset 0))
509 (sap-ref-double sap offset)))
512 (defmethod alien-type ((type (eql 'base-char)) &rest args)
513 (declare (ignore type args))
514 #+cmu 'c-call:char #+sbcl 'sb-alien:char)
516 (defmethod size-of ((type (eql 'base-char)) &rest args)
517 (declare (ignore type args))
520 (defmethod writer-function ((type (eql 'base-char)) &rest args)
521 (declare (ignore type args))
522 #'(lambda (char location &optional (offset 0))
523 (setf (sap-ref-8 location offset) (char-code char))))
525 (defmethod reader-function ((type (eql 'base-char)) &rest args)
526 (declare (ignore type args))
527 #'(lambda (location &optional (offset 0))
528 (code-char (sap-ref-8 location offset))))
531 (defmethod alien-type ((type (eql 'string)) &rest args)
532 (declare (ignore type args))
533 (alien-type 'pointer))
535 (defmethod size-of ((type (eql 'string)) &rest args)
536 (declare (ignore type args))
539 (defmethod to-alien-form (string (type (eql 'string)) &rest args)
540 (declare (ignore type args))
541 `(let ((string ,string))
542 ;; Always copy strings to prevent seg fault due to GC
544 (vector-sap (coerce string 'simple-base-string))
545 (1+ (length string)))))
547 (defmethod to-alien-function ((type (eql 'string)) &rest args)
548 (declare (ignore type args))
551 (vector-sap (coerce string 'simple-base-string))
552 (1+ (length string)))))
554 (defmethod from-alien-form (string (type (eql 'string)) &rest args)
555 (declare (ignore type args))
556 `(let ((string ,string))
557 (unless (null-pointer-p string)
559 (%naturalize-c-string string)
560 (deallocate-memory string)))))
562 (defmethod from-alien-function ((type (eql 'string)) &rest args)
563 (declare (ignore type args))
565 (unless (null-pointer-p string)
567 (%naturalize-c-string string)
568 (deallocate-memory string)))))
570 (defmethod cleanup-form (string (type (eql 'string)) &rest args)
571 (declare (ignore type args))
572 `(let ((string ,string))
573 (unless (null-pointer-p string)
574 (deallocate-memory string))))
576 (defmethod cleanup-function ((type (eql 'string)) &rest args)
577 (declare (ignore args))
579 (unless (null-pointer-p string)
580 (deallocate-memory string))))
582 (defmethod copy-from-alien-form (string (type (eql 'string)) &rest args)
583 (declare (ignore type args))
584 `(let ((string ,string))
585 (unless (null-pointer-p string)
586 (%naturalize-c-string string))))
589 (defmethod copy-from-alien-function ((type (eql 'string)) &rest args)
590 (declare (ignore type args))
592 (unless (null-pointer-p string)
593 (%naturalize-c-string string))))
595 (defmethod writer-function ((type (eql 'string)) &rest args)
596 (declare (ignore type args))
597 #'(lambda (string location &optional (offset 0))
598 (assert (null-pointer-p (sap-ref-sap location offset)))
599 (setf (sap-ref-sap location offset)
601 (vector-sap (coerce string 'simple-base-string))
602 (1+ (length string))))))
604 (defmethod reader-function ((type (eql 'string)) &rest args)
605 (declare (ignore type args))
606 #'(lambda (location &optional (offset 0))
607 (unless (null-pointer-p (sap-ref-sap location offset))
608 (%naturalize-c-string (sap-ref-sap location offset)))))
610 (defmethod destroy-function ((type (eql 'string)) &rest args)
611 (declare (ignore type args))
612 #'(lambda (location &optional (offset 0))
613 (unless (null-pointer-p (sap-ref-sap location offset))
614 (deallocate-memory (sap-ref-sap location offset))
615 (setf (sap-ref-sap location offset) (make-pointer 0)))))
617 (defmethod unbound-value ((type (eql 'string)) &rest args)
618 (declare (ignore type args))
621 (defmethod alien-type ((type (eql 'pathname)) &rest args)
622 (declare (ignore type args))
623 (alien-type 'string))
625 (defmethod size-of ((type (eql 'pathname)) &rest args)
626 (declare (ignore type args))
629 (defmethod to-alien-form (path (type (eql 'pathname)) &rest args)
630 (declare (ignore type args))
631 (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string))
633 (defmethod to-alien-function ((type (eql 'pathname)) &rest args)
634 (declare (ignore type args))
635 (let ((string-function (to-alien-function 'string)))
637 (funcall string-function (namestring path)))))
639 (defmethod from-alien-form (string (type (eql 'pathname)) &rest args)
640 (declare (ignore type args))
641 `(parse-namestring ,(from-alien-form string 'string)))
643 (defmethod from-alien-function ((type (eql 'pathname)) &rest args)
644 (declare (ignore type args))
645 (let ((string-function (from-alien-function 'string)))
647 (parse-namestring (funcall string-function string)))))
649 (defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args)
650 (declare (ignore type args))
651 (cleanup-form string 'string))
653 (defmethod cleanup-function ((type (eql 'pathnanme)) &rest args)
654 (declare (ignore type args))
655 (cleanup-function 'string))
657 (defmethod writer-function ((type (eql 'pathname)) &rest args)
658 (declare (ignore type args))
659 (let ((string-writer (writer-function 'string)))
660 #'(lambda (path location &optional (offset 0))
661 (funcall string-writer (namestring path) location offset))))
663 (defmethod reader-function ((type (eql 'pathname)) &rest args)
664 (declare (ignore type args))
665 (let ((string-reader (reader-function 'string)))
666 #'(lambda (location &optional (offset 0))
667 (let ((string (funcall string-reader location offset)))
669 (parse-namestring string))))))
671 (defmethod destroy-function ((type (eql 'pathname)) &rest args)
672 (declare (ignore type args))
673 (destroy-function 'string))
675 (defmethod unbound-value ((type (eql 'pathname)) &rest args)
676 (declare (ignore type args))
677 (unbound-value 'string))
680 (defmethod alien-type ((type (eql 'boolean)) &rest args)
681 (apply #'alien-type 'signed-byte args))
683 (defmethod size-of ((type (eql 'boolean)) &rest args)
684 (apply #'size-of 'signed-byte args))
686 (defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args)
687 (declare (ignore type args))
690 (defmethod to-alien-function ((type (eql 'boolean)) &rest args)
691 (declare (ignore type args))
695 (defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args)
696 (declare (ignore type args))
697 `(not (zerop ,boolean)))
699 (defmethod from-alien-function ((type (eql 'boolean)) &rest args)
700 (declare (ignore type args))
702 (not (zerop boolean))))
704 (defmethod writer-function ((type (eql 'boolean)) &rest args)
705 (declare (ignore type))
706 (let ((writer (apply #'writer-function 'signed-byte args)))
707 #'(lambda (boolean location &optional (offset 0))
708 (funcall writer (if boolean 1 0) location offset))))
710 (defmethod reader-function ((type (eql 'boolean)) &rest args)
711 (declare (ignore type))
712 (let ((reader (apply #'reader-function 'signed-byte args)))
713 #'(lambda (location &optional (offset 0))
714 (not (zerop (funcall reader location offset))))))
717 (defmethod alien-type ((type (eql 'or)) &rest args)
718 (let ((alien-type (alien-type (first args))))
719 (unless (every #'(lambda (type)
720 (eq alien-type (alien-type type)))
722 (error "No common alien type specifier for union type: ~A"
726 (defmethod size-of ((type (eql 'or)) &rest args)
727 (declare (ignore type))
728 (size-of (first args)))
730 (defmethod to-alien-form (form (type (eql 'or)) &rest args)
731 (declare (ignore type))
732 `(let ((value ,form))
736 `(,type ,(to-alien-form 'value type)))
739 (defmethod to-alien-function ((type (eql 'or)) &rest types)
740 (declare (ignore type))
741 (let ((functions (mapcar #'to-alien-function types)))
744 for function in functions
746 when (typep value type)
747 do (return (funcall function value))
748 finally (error "~S is not of type ~A" value `(or ,@types))))))
750 (defmethod alien-type ((type (eql 'system-area-pointer)) &rest args)
751 (declare (ignore type args))
752 'system-area-pointer)
754 (defmethod size-of ((type (eql 'system-area-pointer)) &rest args)
755 (declare (ignore type args))
758 (defmethod writer-function ((type (eql 'system-area-pointer)) &rest args)
759 (declare (ignore type args))
760 #'(lambda (sap location &optional (offset 0))
761 (setf (sap-ref-sap location offset) sap)))
763 (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
764 (declare (ignore type args))
765 #'(lambda (location &optional (offset 0))
766 (sap-ref-sap location offset)))
769 (defmethod alien-type ((type (eql 'null)) &rest args)
770 (declare (ignore type args))
771 (alien-type 'pointer))
773 (defmethod size-of ((type (eql 'null)) &rest args)
774 (declare (ignore type args))
777 (defmethod to-alien-form (null (type (eql 'null)) &rest args)
778 (declare (ignore null type args))
781 (defmethod to-alien-function ((type (eql 'null)) &rest args)
782 (declare (ignore type args))
784 (declare (ignore null))
788 (defmethod alien-type ((type (eql 'nil)) &rest args)
789 (declare (ignore type args))
792 (defmethod from-alien-function ((type (eql 'nil)) &rest args)
793 (declare (ignore type args))
795 (declare (ignore value))
799 (defmethod alien-type ((type (eql 'copy-of)) &rest args)
800 (declare (ignore type))
801 (alien-type (first args)))
803 (defmethod size-of ((type (eql 'copy-of)) &rest args)
804 (declare (ignore type))
805 (size-of (first args)))
807 (defmethod to-alien-form (form (type (eql 'copy-of)) &rest args)
808 (declare (ignore type))
809 (copy-to-alien-form form (first args)))
811 (defmethod to-alien-function ((type (eql 'copy-of)) &rest args)
812 (declare (ignore type))
813 (copy-to-alien-function (first args)))
815 (defmethod from-alien-form (form (type (eql 'copy-of)) &rest args)
816 (declare (ignore type))
817 (copy-from-alien-form form (first args)))
819 (defmethod from-alien-function ((type (eql 'copy-of)) &rest args)
820 (declare (ignore type))
821 (copy-from-alien-function (first args)))
823 (defmethod reader-function ((type (eql 'copy-of)) &rest args)
824 (declare (ignore type))
825 (reader-function (first args)))
827 (defmethod writer-function ((type (eql 'copy-of)) &rest args)
828 (declare (ignore type))
829 (writer-function (first args)))
832 (defmethod alien-type ((type (eql 'callback)) &rest args)
833 (declare (ignore type args))
834 (alien-type 'pointer))
836 (defmethod size-of ((type (eql 'callback)) &rest args)
837 (declare (ignore type args))
840 (defmethod to-alien-form (callback (type (eql 'callback)) &rest args)
841 (declare (ignore type args))
842 #+cmu `(callback ,callback)
843 #+sbcl `(sb-alien:alien-function-sap ,callback))
845 (defmethod to-alien-function ((type (eql 'callback)) &rest args)
846 (declare (ignore type args))
847 #+cmu #'(lambda (callback) (callback callback))
848 #+sbcl #'sb-alien:alien-function-sap)
851 (defun find-callback (pointer)
852 (find pointer alien::*callbacks* :key #'callback-trampoline :test #'sap=))
854 (defmethod from-alien-form (pointer (type (eql 'callback)) &rest args)
855 (declare (ignore type args))
856 #+cmu `(find-callback ,pointer)
857 #+sbcl `(sb-alien::%find-alien-function ,pointer))
859 (defmethod from-alien-function ((type (eql 'callback)) &rest args)
860 (declare (ignore type args))
861 #+cmu #'find-callback
862 #+sbcl #'sb-alien::%find-alien-function)
864 (defmethod writer-function ((type (eql 'callback)) &rest args)
865 (declare (ignore type args))
866 (let ((writer (writer-function 'pointer))
867 (to-alien (to-alien-function 'callback)))
868 #'(lambda (callback location &optional (offset 0))
869 (funcall writer (funcall to-alien callback) location offset))))
871 (defmethod reader-function ((type (eql 'callback)) &rest args)
872 (declare (ignore type args))
873 (let ((reader (reader-function 'pointer))
874 (from-alien (from-alien-function 'callback)))
875 #'(lambda (location &optional (offset 0))
876 (let ((pointer (funcall reader location offset)))
877 (unless (null-pointer-p pointer)
878 (funcall from-alien pointer))))))
880 (defmethod unbound-value ((type (eql 'callback)) &rest args)
881 (declare (ignore type args))