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.18 2005-03-13 18:06:51 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))))
211 (mapcar #'(lambda (arg)
212 (destructuring-bind (name type) arg
214 (from-alien-form name type)))
215 (unless (eq name from-alien)
216 `(,name ,from-alien)))))
223 (sb-alien:alien-function-sap af))
226 (deftype callback () 'sb-alien:alien-function)
228 ;;;; Definitons and translations of fundamental types
230 (defmacro def-type-method (name args &optional documentation)
232 (defgeneric ,name (,@args type &rest args)
233 ,@(when documentation `((:documentation ,documentation))))
234 (defmethod ,name (,@args (type symbol) &rest args)
235 (let ((class (find-class type nil)))
237 (apply #',name ,@args class args)
238 (multiple-value-bind (super-type expanded-p)
239 (type-expand-1 (cons type args))
241 (,name ,@args super-type)
242 (call-next-method))))))
243 (defmethod ,name (,@args (type cons) &rest args)
244 (declare (ignore args))
245 (apply #',name ,@args (first type) (rest type)))))
248 (def-type-method alien-type ())
249 (def-type-method size-of ())
250 (def-type-method to-alien-form (form))
251 (def-type-method from-alien-form (form))
252 (def-type-method cleanup-form (form)
253 "Creates a form to clean up after the alien call has finished.")
255 (def-type-method to-alien-function ())
256 (def-type-method from-alien-function ())
257 (def-type-method cleanup-function ())
259 (def-type-method copy-to-alien-form (form))
260 (def-type-method copy-to-alien-function ())
261 (def-type-method copy-from-alien-form (form))
262 (def-type-method copy-from-alien-function ())
264 (def-type-method writer-function ())
265 (def-type-method reader-function ())
266 (def-type-method destroy-function ())
268 (def-type-method unbound-value ()
269 "First return value is true if the type has an unbound value, second return value is the actual unbound value")
272 ;; Sizes of fundamental C types in bytes (8 bits)
273 (defconstant +size-of-short+ 2)
274 (defconstant +size-of-int+ 4)
275 (defconstant +size-of-long+ 4)
276 (defconstant +size-of-pointer+ 4)
277 (defconstant +size-of-float+ 4)
278 (defconstant +size-of-double+ 8)
280 ;; Sizes of fundamental C types in bits
281 (defconstant +bits-of-byte+ 8)
282 (defconstant +bits-of-short+ 16)
283 (defconstant +bits-of-int+ 32)
284 (defconstant +bits-of-long+ 32)
287 (deftype int () '(signed-byte #.+bits-of-int+))
288 (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+))
289 (deftype long () '(signed-byte #.+bits-of-long+))
290 (deftype unsigned-long () '(unsigned-byte #.+bits-of-long+))
291 (deftype short () '(signed-byte #.+bits-of-short+))
292 (deftype unsigned-short () '(unsigned-byte #.+bits-of-short+))
293 (deftype signed (&optional (size '*)) `(signed-byte ,size))
294 (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
295 (deftype char () 'base-char)
296 (deftype pointer () 'system-area-pointer)
297 (deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil))
298 ;(deftype invalid () nil)
301 (defmethod to-alien-form (form (type t) &rest args)
302 (declare (ignore type args))
305 (defmethod to-alien-function ((type t) &rest args)
306 (declare (ignore type args))
309 (defmethod from-alien-form (form (type t) &rest args)
310 (declare (ignore type args))
313 (defmethod from-alien-function ((type t) &rest args)
314 (declare (ignore type args))
317 (defmethod cleanup-form (form (type t) &rest args)
318 (declare (ignore form type args))
321 (defmethod cleanup-function ((type t) &rest args)
322 (declare (ignore type args))
325 (defmethod destroy-function ((type t) &rest args)
326 (declare (ignore type args))
327 #'(lambda (location &optional offset)
328 (declare (ignore location offset))))
330 (defmethod copy-to-alien-form (form (type t) &rest args)
331 (apply #'to-alien-form form type args))
333 (defmethod copy-to-alien-function ((type t) &rest args)
334 (apply #'to-alien-function type args))
336 (defmethod copy-from-alien-form (form (type t) &rest args)
337 (apply #'from-alien-form form type args))
339 (defmethod copy-from-alien-function ((type t) &rest args)
340 (apply #'from-alien-function type args))
343 (defmethod alien-type ((type (eql 'signed-byte)) &rest args)
344 (declare (ignore type))
345 (destructuring-bind (&optional (size '*)) args
347 (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8))
348 (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short)
349 ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int)
350 (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long))))
352 (defmethod size-of ((type (eql 'signed-byte)) &rest args)
353 (declare (ignore type))
354 (destructuring-bind (&optional (size '*)) args
357 (#.+bits-of-short+ +size-of-short+)
358 ((* #.+bits-of-int+) +size-of-int+)
359 (#.+bits-of-long+ +size-of-long+))))
361 (defmethod unbound-value ((type t) &rest args)
362 (declare (ignore type args))
365 (defmethod writer-function ((type (eql 'signed-byte)) &rest args)
366 (declare (ignore type))
367 (destructuring-bind (&optional (size '*)) args
368 (let ((size (if (eq size '*) +bits-of-int+ size)))
370 (8 #'(lambda (value location &optional (offset 0))
371 (setf (signed-sap-ref-8 location offset) value)))
372 (16 #'(lambda (value location &optional (offset 0))
373 (setf (signed-sap-ref-16 location offset) value)))
374 (32 #'(lambda (value location &optional (offset 0))
375 (setf (signed-sap-ref-32 location offset) value)))
376 (64 #'(lambda (value location &optional (offset 0))
377 (setf (signed-sap-ref-64 location offset) value)))))))
379 (defmethod reader-function ((type (eql 'signed-byte)) &rest args)
380 (declare (ignore type))
381 (destructuring-bind (&optional (size '*)) args
382 (let ((size (if (eq size '*) +bits-of-int+ size)))
384 (8 #'(lambda (sap &optional (offset 0))
385 (signed-sap-ref-8 sap offset)))
386 (16 #'(lambda (sap &optional (offset 0))
387 (signed-sap-ref-16 sap offset)))
388 (32 #'(lambda (sap &optional (offset 0))
389 (signed-sap-ref-32 sap offset)))
390 (64 #'(lambda (sap &optional (offset 0))
391 (signed-sap-ref-64 sap offset)))))))
393 (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)
394 (destructuring-bind (&optional (size '*)) args
396 (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8))
397 (#.+bits-of-short+ #+cmu 'c-call:unsigned-short
398 #+sbcl 'sb-alien:unsigned-short)
399 ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int
400 #+sbcl 'sb-alien:unsigned-int)
401 (#.+bits-of-long+ #+cmu 'c-call:unsigned-long
402 #+sbcl 'sb-alien:unsigned-long))))
404 (defmethod size-of ((type (eql 'unsigned-byte)) &rest args)
405 (apply #'size-of 'signed args))
407 (defmethod writer-function ((type (eql 'unsigned-byte)) &rest args)
408 (declare (ignore type))
409 (destructuring-bind (&optional (size '*)) args
410 (let ((size (if (eq size '*) +bits-of-int+ size)))
412 (8 #'(lambda (value location &optional (offset 0))
413 (setf (sap-ref-8 location offset) value)))
414 (16 #'(lambda (value location &optional (offset 0))
415 (setf (sap-ref-16 location offset) value)))
416 (32 #'(lambda (value location &optional (offset 0))
417 (setf (sap-ref-32 location offset) value)))
418 (64 #'(lambda (value location &optional (offset 0))
419 (setf (sap-ref-64 location offset) value)))))))
421 (defmethod reader-function ((type (eql 'unsigned-byte)) &rest args)
422 (declare (ignore type))
423 (destructuring-bind (&optional (size '*)) args
424 (let ((size (if (eq size '*) +bits-of-int+ size)))
426 (8 #'(lambda (sap &optional (offset 0))
427 (sap-ref-8 sap offset)))
428 (16 #'(lambda (sap &optional (offset 0))
429 (sap-ref-16 sap offset)))
430 (32 #'(lambda (sap &optional (offset 0))
431 (sap-ref-32 sap offset)))
432 (64 #'(lambda (sap &optional (offset 0))
433 (sap-ref-64 sap offset)))))))
436 (defmethod alien-type ((type (eql 'integer)) &rest args)
437 (declare (ignore type args))
438 (alien-type 'signed-byte))
440 (defmethod size-of ((type (eql 'integer)) &rest args)
441 (declare (ignore type args))
442 (size-of 'signed-byte))
444 (defmethod writer-function ((type (eql 'integer)) &rest args)
445 (declare (ignore type args))
446 (writer-function 'signed-byte))
448 (defmethod reader-function ((type (eql 'integer)) &rest args)
449 (declare (ignore type args))
450 (reader-function 'signed-byte))
453 (defmethod alien-type ((type (eql 'fixnum)) &rest args)
454 (declare (ignore type args))
455 (alien-type 'signed-byte))
457 (defmethod size-of ((type (eql 'fixnum)) &rest args)
458 (declare (ignore type args))
459 (size-of 'signed-byte))
462 (defmethod alien-type ((type (eql 'single-float)) &rest args)
463 (declare (ignore type args))
464 #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float)
466 (defmethod size-of ((type (eql 'single-float)) &rest args)
467 (declare (ignore type args))
470 (defmethod to-alien-form (form (type (eql 'single-float)) &rest args)
471 (declare (ignore type args))
472 `(coerce ,form 'single-float))
474 (defmethod to-alien-function ((type (eql 'single-float)) &rest args)
475 (declare (ignore type args))
477 (coerce number 'single-float)))
479 (defmethod writer-function ((type (eql 'single-float)) &rest args)
480 (declare (ignore type args))
481 #'(lambda (value location &optional (offset 0))
482 (setf (sap-ref-single location offset) (coerce value 'single-float))))
484 (defmethod reader-function ((type (eql 'single-float)) &rest args)
485 (declare (ignore type args))
486 #'(lambda (sap &optional (offset 0))
487 (sap-ref-single sap offset)))
490 (defmethod alien-type ((type (eql 'double-float)) &rest args)
491 (declare (ignore type args))
492 #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float)
494 (defmethod size-of ((type (eql 'double-float)) &rest args)
495 (declare (ignore type args))
498 (defmethod to-alien-form (form (type (eql 'double-float)) &rest args)
499 (declare (ignore type args))
500 `(coerce ,form 'double-float))
502 (defmethod to-alien-function ((type (eql 'double-float)) &rest args)
503 (declare (ignore type args))
505 (coerce number 'double-float)))
507 (defmethod writer-function ((type (eql 'double-float)) &rest args)
508 (declare (ignore type args))
509 #'(lambda (value location &optional (offset 0))
510 (setf (sap-ref-double location offset) (coerce value 'double-float))))
512 (defmethod reader-function ((type (eql 'double-float)) &rest args)
513 (declare (ignore type args))
514 #'(lambda (sap &optional (offset 0))
515 (sap-ref-double sap offset)))
518 (defmethod alien-type ((type (eql 'base-char)) &rest args)
519 (declare (ignore type args))
520 #+cmu 'c-call:char #+sbcl 'sb-alien:char)
522 (defmethod size-of ((type (eql 'base-char)) &rest args)
523 (declare (ignore type args))
526 (defmethod writer-function ((type (eql 'base-char)) &rest args)
527 (declare (ignore type args))
528 #'(lambda (char location &optional (offset 0))
529 (setf (sap-ref-8 location offset) (char-code char))))
531 (defmethod reader-function ((type (eql 'base-char)) &rest args)
532 (declare (ignore type args))
533 #'(lambda (location &optional (offset 0))
534 (code-char (sap-ref-8 location offset))))
537 (defmethod alien-type ((type (eql 'string)) &rest args)
538 (declare (ignore type args))
539 (alien-type 'pointer))
541 (defmethod size-of ((type (eql 'string)) &rest args)
542 (declare (ignore type args))
545 (defmethod to-alien-form (string (type (eql 'string)) &rest args)
546 (declare (ignore type args))
547 `(let ((string ,string))
548 ;; Always copy strings to prevent seg fault due to GC
550 (vector-sap (coerce string 'simple-base-string))
551 (1+ (length string)))))
553 (defmethod to-alien-function ((type (eql 'string)) &rest args)
554 (declare (ignore type args))
557 (vector-sap (coerce string 'simple-base-string))
558 (1+ (length string)))))
560 (defmethod from-alien-form (string (type (eql 'string)) &rest args)
561 (declare (ignore type args))
562 `(let ((string ,string))
563 (unless (null-pointer-p string)
565 (%naturalize-c-string string)
566 (deallocate-memory string)))))
568 (defmethod from-alien-function ((type (eql 'string)) &rest args)
569 (declare (ignore type args))
571 (unless (null-pointer-p string)
573 (%naturalize-c-string string)
574 (deallocate-memory string)))))
576 (defmethod cleanup-form (string (type (eql 'string)) &rest args)
577 (declare (ignore type args))
578 `(let ((string ,string))
579 (unless (null-pointer-p string)
580 (deallocate-memory string))))
582 (defmethod cleanup-function ((type (eql 'string)) &rest args)
583 (declare (ignore args))
585 (unless (null-pointer-p string)
586 (deallocate-memory string))))
588 (defmethod copy-from-alien-form (string (type (eql 'string)) &rest args)
589 (declare (ignore type args))
590 `(let ((string ,string))
591 (unless (null-pointer-p string)
592 (%naturalize-c-string string))))
595 (defmethod copy-from-alien-function ((type (eql 'string)) &rest args)
596 (declare (ignore type args))
598 (unless (null-pointer-p string)
599 (%naturalize-c-string string))))
601 (defmethod writer-function ((type (eql 'string)) &rest args)
602 (declare (ignore type args))
603 #'(lambda (string location &optional (offset 0))
604 (assert (null-pointer-p (sap-ref-sap location offset)))
605 (setf (sap-ref-sap location offset)
607 (vector-sap (coerce string 'simple-base-string))
608 (1+ (length string))))))
610 (defmethod reader-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 (%naturalize-c-string (sap-ref-sap location offset)))))
616 (defmethod destroy-function ((type (eql 'string)) &rest args)
617 (declare (ignore type args))
618 #'(lambda (location &optional (offset 0))
619 (unless (null-pointer-p (sap-ref-sap location offset))
620 (deallocate-memory (sap-ref-sap location offset))
621 (setf (sap-ref-sap location offset) (make-pointer 0)))))
623 (defmethod unbound-value ((type (eql 'string)) &rest args)
624 (declare (ignore type args))
627 (defmethod alien-type ((type (eql 'pathname)) &rest args)
628 (declare (ignore type args))
629 (alien-type 'string))
631 (defmethod size-of ((type (eql 'pathname)) &rest args)
632 (declare (ignore type args))
635 (defmethod to-alien-form (path (type (eql 'pathname)) &rest args)
636 (declare (ignore type args))
637 (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string))
639 (defmethod to-alien-function ((type (eql 'pathname)) &rest args)
640 (declare (ignore type args))
641 (let ((string-function (to-alien-function 'string)))
643 (funcall string-function (namestring path)))))
645 (defmethod from-alien-form (string (type (eql 'pathname)) &rest args)
646 (declare (ignore type args))
647 `(parse-namestring ,(from-alien-form string 'string)))
649 (defmethod from-alien-function ((type (eql 'pathname)) &rest args)
650 (declare (ignore type args))
651 (let ((string-function (from-alien-function 'string)))
653 (parse-namestring (funcall string-function string)))))
655 (defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args)
656 (declare (ignore type args))
657 (cleanup-form string 'string))
659 (defmethod cleanup-function ((type (eql 'pathnanme)) &rest args)
660 (declare (ignore type args))
661 (cleanup-function 'string))
663 (defmethod writer-function ((type (eql 'pathname)) &rest args)
664 (declare (ignore type args))
665 (let ((string-writer (writer-function 'string)))
666 #'(lambda (path location &optional (offset 0))
667 (funcall string-writer (namestring path) location offset))))
669 (defmethod reader-function ((type (eql 'pathname)) &rest args)
670 (declare (ignore type args))
671 (let ((string-reader (reader-function 'string)))
672 #'(lambda (location &optional (offset 0))
673 (let ((string (funcall string-reader location offset)))
675 (parse-namestring string))))))
677 (defmethod destroy-function ((type (eql 'pathname)) &rest args)
678 (declare (ignore type args))
679 (destroy-function 'string))
681 (defmethod unbound-value ((type (eql 'pathname)) &rest args)
682 (declare (ignore type args))
683 (unbound-value 'string))
686 (defmethod alien-type ((type (eql 'boolean)) &rest args)
687 (apply #'alien-type 'signed-byte args))
689 (defmethod size-of ((type (eql 'boolean)) &rest args)
690 (apply #'size-of 'signed-byte args))
692 (defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args)
693 (declare (ignore type args))
696 (defmethod to-alien-function ((type (eql 'boolean)) &rest args)
697 (declare (ignore type args))
701 (defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args)
702 (declare (ignore type args))
703 `(not (zerop ,boolean)))
705 (defmethod from-alien-function ((type (eql 'boolean)) &rest args)
706 (declare (ignore type args))
708 (not (zerop boolean))))
710 (defmethod writer-function ((type (eql 'boolean)) &rest args)
711 (declare (ignore type))
712 (let ((writer (apply #'writer-function 'signed-byte args)))
713 #'(lambda (boolean location &optional (offset 0))
714 (funcall writer (if boolean 1 0) location offset))))
716 (defmethod reader-function ((type (eql 'boolean)) &rest args)
717 (declare (ignore type))
718 (let ((reader (apply #'reader-function 'signed-byte args)))
719 #'(lambda (location &optional (offset 0))
720 (not (zerop (funcall reader location offset))))))
723 (defmethod alien-type ((type (eql 'or)) &rest args)
724 (let ((alien-type (alien-type (first args))))
725 (unless (every #'(lambda (type)
726 (eq alien-type (alien-type type)))
728 (error "No common alien type specifier for union type: ~A"
732 (defmethod size-of ((type (eql 'or)) &rest args)
733 (declare (ignore type))
734 (size-of (first args)))
736 (defmethod to-alien-form (form (type (eql 'or)) &rest args)
737 (declare (ignore type))
738 `(let ((value ,form))
742 `(,type ,(to-alien-form 'value type)))
745 (defmethod to-alien-function ((type (eql 'or)) &rest types)
746 (declare (ignore type))
747 (let ((functions (mapcar #'to-alien-function types)))
750 for function in functions
752 when (typep value type)
753 do (return (funcall function value))
754 finally (error "~S is not of type ~A" value `(or ,@types))))))
756 (defmethod alien-type ((type (eql 'system-area-pointer)) &rest args)
757 (declare (ignore type args))
758 'system-area-pointer)
760 (defmethod size-of ((type (eql 'system-area-pointer)) &rest args)
761 (declare (ignore type args))
764 (defmethod writer-function ((type (eql 'system-area-pointer)) &rest args)
765 (declare (ignore type args))
766 #'(lambda (sap location &optional (offset 0))
767 (setf (sap-ref-sap location offset) sap)))
769 (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
770 (declare (ignore type args))
771 #'(lambda (location &optional (offset 0))
772 (sap-ref-sap location offset)))
775 (defmethod alien-type ((type (eql 'null)) &rest args)
776 (declare (ignore type args))
777 (alien-type 'pointer))
779 (defmethod size-of ((type (eql 'null)) &rest args)
780 (declare (ignore type args))
783 (defmethod to-alien-form (null (type (eql 'null)) &rest args)
784 (declare (ignore null type args))
787 (defmethod to-alien-function ((type (eql 'null)) &rest args)
788 (declare (ignore type args))
790 (declare (ignore null))
794 (defmethod alien-type ((type (eql 'nil)) &rest args)
795 (declare (ignore type args))
798 (defmethod from-alien-function ((type (eql 'nil)) &rest args)
799 (declare (ignore type args))
801 (declare (ignore value))
805 (defmethod alien-type ((type (eql 'copy-of)) &rest args)
806 (declare (ignore type))
807 (alien-type (first args)))
809 (defmethod size-of ((type (eql 'copy-of)) &rest args)
810 (declare (ignore type))
811 (size-of (first args)))
813 (defmethod to-alien-form (form (type (eql 'copy-of)) &rest args)
814 (declare (ignore type))
815 (copy-to-alien-form form (first args)))
817 (defmethod to-alien-function ((type (eql 'copy-of)) &rest args)
818 (declare (ignore type))
819 (copy-to-alien-function (first args)))
821 (defmethod from-alien-form (form (type (eql 'copy-of)) &rest args)
822 (declare (ignore type))
823 (copy-from-alien-form form (first args)))
825 (defmethod from-alien-function ((type (eql 'copy-of)) &rest args)
826 (declare (ignore type))
827 (copy-from-alien-function (first args)))
829 (defmethod reader-function ((type (eql 'copy-of)) &rest args)
830 (declare (ignore type))
831 (reader-function (first args)))
833 (defmethod writer-function ((type (eql 'copy-of)) &rest args)
834 (declare (ignore type))
835 (writer-function (first args)))
838 (defmethod alien-type ((type (eql 'callback)) &rest args)
839 (declare (ignore type args))
840 (alien-type 'pointer))
842 (defmethod size-of ((type (eql 'callback)) &rest args)
843 (declare (ignore type args))
846 (defmethod to-alien-form (callback (type (eql 'callback)) &rest args)
847 (declare (ignore type args))
848 #+cmu `(callback ,callback)
849 #+sbcl `(sb-alien:alien-function-sap ,callback))
851 (defmethod to-alien-function ((type (eql 'callback)) &rest args)
852 (declare (ignore type args))
853 #+cmu #'(lambda (callback) (callback callback))
854 #+sbcl #'sb-alien:alien-function-sap)
857 (defun find-callback (pointer)
858 (find pointer alien::*callbacks* :key #'callback-trampoline :test #'sap=))
860 (defmethod from-alien-form (pointer (type (eql 'callback)) &rest args)
861 (declare (ignore type args))
862 #+cmu `(find-callback ,pointer)
863 #+sbcl `(sb-alien::%find-alien-function ,pointer))
865 (defmethod from-alien-function ((type (eql 'callback)) &rest args)
866 (declare (ignore type args))
867 #+cmu #'find-callback
868 #+sbcl #'sb-alien::%find-alien-function)
870 (defmethod writer-function ((type (eql 'callback)) &rest args)
871 (declare (ignore type args))
872 (let ((writer (writer-function 'pointer))
873 (to-alien (to-alien-function 'callback)))
874 #'(lambda (callback location &optional (offset 0))
875 (funcall writer (funcall to-alien callback) location offset))))
877 (defmethod reader-function ((type (eql 'callback)) &rest args)
878 (declare (ignore type args))
879 (let ((reader (reader-function 'pointer))
880 (from-alien (from-alien-function 'callback)))
881 #'(lambda (location &optional (offset 0))
882 (let ((pointer (funcall reader location offset)))
883 (unless (null-pointer-p pointer)
884 (funcall from-alien pointer))))))
886 (defmethod unbound-value ((type (eql 'callback)) &rest args)
887 (declare (ignore type args))