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.13 2005-02-03 23:09:03 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))
131 ,@(when (eq style :in-out)
132 (list (to-alien-form expr type)))))
133 (return-values (from-alien-form var type)))
135 (alien-types declaration)
137 `(,var ,declaration ,(to-alien-form expr type)))
138 (alien-parameters var)
139 (return-values (from-alien-form var type)))
141 (alien-types declaration)
143 `(,var ,declaration ,(to-alien-form expr type)))
144 (alien-parameters var)
145 (cleanup-forms cleanup))
147 (alien-types declaration)
148 (alien-parameters (to-alien-form expr type)))))))
150 (let* ((alien-name (make-symbol (string lisp-name)))
151 (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters))))
152 `(defun ,lisp-name ,lambda-list
154 #+cmu(declare (optimize (inhibit-warnings 3)))
155 #+sbcl(declare (muffle-conditions compiler-note))
156 (with-alien ((,alien-name
158 ,(alien-type return-type)
160 :extern ,foreign-name)
165 ,(from-alien-form alien-funcall return-type)
172 (values ,@(return-values)))))))))
175 ;;; Creates bindings at runtime
176 (defun mkbinding (name return-type &rest arg-types)
177 #+cmu(declare (optimize (inhibit-warnings 3)))
178 #+sbcl(declare (muffle-conditions compiler-note))
180 `(function ,@(mapcar #'alien-type (cons return-type arg-types))))
183 (make-heap-alien-info
184 :type (parse-alien-type ftype #+sbcl nil)
185 :sap-form (foreign-symbol-address name))))
186 (translate-arguments (mapcar #'to-alien-function arg-types))
187 (translate-return-value (from-alien-function return-type))
188 (cleanup-arguments (mapcar #'cleanup-function arg-types)))
190 #'(lambda (&rest args)
191 (map-into args #'funcall translate-arguments args)
193 (funcall translate-return-value
194 (apply #'alien-funcall alien args))
195 (mapc #'funcall cleanup-arguments args)))))
198 (defmacro defcallback (name (return-type &rest args) &body body)
199 (let ((def-callback #+cmu'alien:def-callback
200 #+sbcl'sb-alien:define-alien-function))
201 `(,def-callback ,name
202 (,(alien-type return-type)
203 ,@(mapcar #'(lambda (arg)
204 (destructuring-bind (name type) arg
205 `(,name ,(alien-type type))))
208 `(let (,@(mapcar #'(lambda (arg)
209 (destructuring-bind (name type) arg
210 `(,name ,(from-alien-form name type))))
217 (sb-alien:alien-function-sap af))
220 ;;;; Definitons and translations of fundamental types
222 (defmacro def-type-method (name args &optional documentation)
224 (defgeneric ,name (,@args type &rest args)
225 ,@(when documentation `((:documentation ,documentation))))
226 (defmethod ,name (,@args (type symbol) &rest args)
227 (let ((class (find-class type nil)))
229 (apply #',name ,@args class args)
230 (multiple-value-bind (super-type expanded-p)
231 (type-expand-1 (cons type args))
233 (,name ,@args super-type)
234 (call-next-method))))))
235 (defmethod ,name (,@args (type cons) &rest args)
236 (declare (ignore args))
237 (apply #',name ,@args (first type) (rest type)))))
240 (def-type-method alien-type ())
241 (def-type-method size-of ())
242 (def-type-method to-alien-form (form))
243 (def-type-method from-alien-form (form))
244 (def-type-method cleanup-form (form)
245 "Creates a form to clean up after the alien call has finished.")
247 (def-type-method to-alien-function ())
248 (def-type-method from-alien-function ())
249 (def-type-method cleanup-function ())
251 (def-type-method copy-to-alien-form (form))
252 (def-type-method copy-to-alien-function ())
253 (def-type-method copy-from-alien-form (form))
254 (def-type-method copy-from-alien-function ())
256 (def-type-method writer-function ())
257 (def-type-method reader-function ())
258 (def-type-method destroy-function ())
260 (def-type-method unbound-value ()
261 "First return value is true if the type has an unbound value, second return value is the actual unbound value")
264 ;; Sizes of fundamental C types in bytes (8 bits)
265 (defconstant +size-of-short+ 2)
266 (defconstant +size-of-int+ 4)
267 (defconstant +size-of-long+ 4)
268 (defconstant +size-of-pointer+ 4)
269 (defconstant +size-of-float+ 4)
270 (defconstant +size-of-double+ 8)
272 ;; Sizes of fundamental C types in bits
273 (defconstant +bits-of-byte+ 8)
274 (defconstant +bits-of-short+ 16)
275 (defconstant +bits-of-int+ 32)
276 (defconstant +bits-of-long+ 32)
279 (deftype int () '(signed-byte #.+bits-of-int+))
280 (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+))
281 (deftype long () '(signed-byte #.+bits-of-long+))
282 (deftype unsigned-long () '(unsigned-byte #.+bits-of-long+))
283 (deftype short () '(signed-byte #.+bits-of-short+))
284 (deftype unsigned-short () '(unsigned-byte #.+bits-of-short+))
285 (deftype signed (&optional (size '*)) `(signed-byte ,size))
286 (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
287 (deftype char () 'base-char)
288 (deftype pointer () 'system-area-pointer)
289 (deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil))
290 ;(deftype invalid () nil)
293 (defmethod to-alien-form (form (type t) &rest args)
294 (declare (ignore type args))
297 (defmethod to-alien-function ((type t) &rest args)
298 (declare (ignore type args))
301 (defmethod from-alien-form (form (type t) &rest args)
302 (declare (ignore type args))
305 (defmethod from-alien-function ((type t) &rest args)
306 (declare (ignore type args))
309 (defmethod cleanup-form (form (type t) &rest args)
310 (declare (ignore form type args))
313 (defmethod cleanup-function ((type t) &rest args)
314 (declare (ignore type args))
317 (defmethod destroy-function ((type t) &rest args)
318 (declare (ignore type args))
319 #'(lambda (location &optional offset)
320 (declare (ignore location offset))))
322 (defmethod copy-to-alien-form (form (type t) &rest args)
323 (apply #'to-alien-form form type args))
325 (defmethod copy-to-alien-function ((type t) &rest args)
326 (apply #'to-alien-function type args))
328 (defmethod copy-from-alien-form (form (type t) &rest args)
329 (apply #'from-alien-form form type args))
331 (defmethod copy-from-alien-function ((type t) &rest args)
332 (apply #'from-alien-function type args))
335 (defmethod alien-type ((type (eql 'signed-byte)) &rest args)
336 (declare (ignore type))
337 (destructuring-bind (&optional (size '*)) args
339 (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8))
340 (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short)
341 ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int)
342 (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long))))
344 (defmethod size-of ((type (eql 'signed-byte)) &rest args)
345 (declare (ignore type))
346 (destructuring-bind (&optional (size '*)) args
349 (#.+bits-of-short+ +size-of-short+)
350 ((* #.+bits-of-int+) +size-of-int+)
351 (#.+bits-of-long+ +size-of-long+))))
353 (defmethod unbound-value ((type t) &rest args)
354 (declare (ignore type args))
357 (defmethod writer-function ((type (eql 'signed-byte)) &rest args)
358 (declare (ignore type))
359 (destructuring-bind (&optional (size '*)) args
360 (let ((size (if (eq size '*) +bits-of-int+ size)))
362 (8 #'(lambda (value location &optional (offset 0))
363 (setf (signed-sap-ref-8 location offset) value)))
364 (16 #'(lambda (value location &optional (offset 0))
365 (setf (signed-sap-ref-16 location offset) value)))
366 (32 #'(lambda (value location &optional (offset 0))
367 (setf (signed-sap-ref-32 location offset) value)))
368 (64 #'(lambda (value location &optional (offset 0))
369 (setf (signed-sap-ref-64 location offset) value)))))))
371 (defmethod reader-function ((type (eql 'signed-byte)) &rest args)
372 (declare (ignore type))
373 (destructuring-bind (&optional (size '*)) args
374 (let ((size (if (eq size '*) +bits-of-int+ size)))
376 (8 #'(lambda (sap &optional (offset 0))
377 (signed-sap-ref-8 sap offset)))
378 (16 #'(lambda (sap &optional (offset 0))
379 (signed-sap-ref-16 sap offset)))
380 (32 #'(lambda (sap &optional (offset 0))
381 (signed-sap-ref-32 sap offset)))
382 (64 #'(lambda (sap &optional (offset 0))
383 (signed-sap-ref-64 sap offset)))))))
385 (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)
386 (destructuring-bind (&optional (size '*)) args
388 (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8))
389 (#.+bits-of-short+ #+cmu 'c-call:unsigned-short
390 #+sbcl 'sb-alien:unsigned-short)
391 ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int
392 #+sbcl 'sb-alien:unsigned-int)
393 (#.+bits-of-long+ #+cmu 'c-call:unsigned-long
394 #+sbcl 'sb-alien:unsigned-long))))
396 (defmethod size-of ((type (eql 'unsigned-byte)) &rest args)
397 (apply #'size-of 'signed args))
399 (defmethod writer-function ((type (eql 'unsigned-byte)) &rest args)
400 (declare (ignore type))
401 (destructuring-bind (&optional (size '*)) args
402 (let ((size (if (eq size '*) +bits-of-int+ size)))
404 (8 #'(lambda (value location &optional (offset 0))
405 (setf (sap-ref-8 location offset) value)))
406 (16 #'(lambda (value location &optional (offset 0))
407 (setf (sap-ref-16 location offset) value)))
408 (32 #'(lambda (value location &optional (offset 0))
409 (setf (sap-ref-32 location offset) value)))
410 (64 #'(lambda (value location &optional (offset 0))
411 (setf (sap-ref-64 location offset) value)))))))
413 (defmethod reader-function ((type (eql 'unsigned-byte)) &rest args)
414 (declare (ignore type))
415 (destructuring-bind (&optional (size '*)) args
416 (let ((size (if (eq size '*) +bits-of-int+ size)))
418 (8 #'(lambda (sap &optional (offset 0))
419 (sap-ref-8 sap offset)))
420 (16 #'(lambda (sap &optional (offset 0))
421 (sap-ref-16 sap offset)))
422 (32 #'(lambda (sap &optional (offset 0))
423 (sap-ref-32 sap offset)))
424 (64 #'(lambda (sap &optional (offset 0))
425 (sap-ref-64 sap offset)))))))
428 (defmethod alien-type ((type (eql 'integer)) &rest args)
429 (declare (ignore type args))
430 (alien-type 'signed-byte))
432 (defmethod size-of ((type (eql 'integer)) &rest args)
433 (declare (ignore type args))
434 (size-of 'signed-byte))
436 (defmethod writer-function ((type (eql 'integer)) &rest args)
437 (declare (ignore type args))
438 (writer-function 'signed-byte))
440 (defmethod reader-function ((type (eql 'integer)) &rest args)
441 (declare (ignore type args))
442 (reader-function 'signed-byte))
445 (defmethod alien-type ((type (eql 'fixnum)) &rest args)
446 (declare (ignore type args))
447 (alien-type 'signed-byte))
449 (defmethod size-of ((type (eql 'fixnum)) &rest args)
450 (declare (ignore type args))
451 (size-of 'signed-byte))
454 (defmethod alien-type ((type (eql 'single-float)) &rest args)
455 (declare (ignore type args))
456 #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float)
458 (defmethod size-of ((type (eql 'single-float)) &rest args)
459 (declare (ignore type args))
462 (defmethod writer-function ((type (eql 'single-float)) &rest args)
463 (declare (ignore type args))
464 #'(lambda (value location &optional (offset 0))
465 (setf (sap-ref-single location offset) (coerce value 'single-float))))
467 (defmethod reader-function ((type (eql 'single-float)) &rest args)
468 (declare (ignore type args))
469 #'(lambda (sap &optional (offset 0))
470 (sap-ref-single sap offset)))
473 (defmethod alien-type ((type (eql 'double-float)) &rest args)
474 (declare (ignore type args))
475 #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float)
477 (defmethod size-of ((type (eql 'double-float)) &rest args)
478 (declare (ignore type args))
481 (defmethod writer-function ((type (eql 'double-float)) &rest args)
482 (declare (ignore type args))
483 #'(lambda (value location &optional (offset 0))
484 (setf (sap-ref-double location offset) (coerce value 'double-float))))
486 (defmethod reader-function ((type (eql 'double-float)) &rest args)
487 (declare (ignore type args))
488 #'(lambda (sap &optional (offset 0))
489 (sap-ref-double sap offset)))
492 (defmethod alien-type ((type (eql 'base-char)) &rest args)
493 (declare (ignore type args))
494 #+cmu 'c-call:char #+sbcl 'sb-alien:char)
496 (defmethod size-of ((type (eql 'base-char)) &rest args)
497 (declare (ignore type args))
500 (defmethod writer-function ((type (eql 'base-char)) &rest args)
501 (declare (ignore type args))
502 #'(lambda (char location &optional (offset 0))
503 (setf (sap-ref-8 location offset) (char-code char))))
505 (defmethod reader-function ((type (eql 'base-char)) &rest args)
506 (declare (ignore type args))
507 #'(lambda (location &optional (offset 0))
508 (code-char (sap-ref-8 location offset))))
511 (defmethod alien-type ((type (eql 'string)) &rest args)
512 (declare (ignore type args))
513 (alien-type 'pointer))
515 (defmethod size-of ((type (eql 'string)) &rest args)
516 (declare (ignore type args))
519 (defmethod to-alien-form (string (type (eql 'string)) &rest args)
520 (declare (ignore type args))
521 `(let ((string ,string))
522 ;; Always copy strings to prevent seg fault due to GC
524 (vector-sap (coerce string 'simple-base-string))
525 (1+ (length string)))))
527 (defmethod to-alien-function ((type (eql 'string)) &rest args)
528 (declare (ignore type args))
531 (vector-sap (coerce string 'simple-base-string))
532 (1+ (length string)))))
534 (defmethod from-alien-form (string (type (eql 'string)) &rest args)
535 (declare (ignore type args))
536 `(let ((string ,string))
537 (unless (null-pointer-p string)
539 (%naturalize-c-string string)
540 (deallocate-memory string)))))
542 (defmethod from-alien-function ((type (eql 'string)) &rest args)
543 (declare (ignore type args))
545 (unless (null-pointer-p string)
547 (%naturalize-c-string string)
548 (deallocate-memory string)))))
550 (defmethod cleanup-form (string (type (eql 'string)) &rest args)
551 (declare (ignore type args))
552 `(let ((string ,string))
553 (unless (null-pointer-p string)
554 (deallocate-memory string))))
556 (defmethod cleanup-function ((type (eql 'string)) &rest args)
557 (declare (ignore args))
559 (unless (null-pointer-p string)
560 (deallocate-memory string))))
562 (defmethod copy-from-alien-form (string (type (eql 'string)) &rest args)
563 (declare (ignore type args))
564 `(let ((string ,string))
565 (unless (null-pointer-p string)
566 (%naturalize-c-string string))))
569 (defmethod copy-from-alien-function ((type (eql 'string)) &rest args)
570 (declare (ignore type args))
572 (unless (null-pointer-p string)
573 (%naturalize-c-string string))))
575 (defmethod writer-function ((type (eql 'string)) &rest args)
576 (declare (ignore type args))
577 #'(lambda (string location &optional (offset 0))
578 (assert (null-pointer-p (sap-ref-sap location offset)))
579 (setf (sap-ref-sap location offset)
581 (vector-sap (coerce string 'simple-base-string))
582 (1+ (length string))))))
584 (defmethod reader-function ((type (eql 'string)) &rest args)
585 (declare (ignore type args))
586 #'(lambda (location &optional (offset 0))
587 (unless (null-pointer-p (sap-ref-sap location offset))
588 (%naturalize-c-string (sap-ref-sap location offset)))))
590 (defmethod destroy-function ((type (eql 'string)) &rest args)
591 (declare (ignore type args))
592 #'(lambda (location &optional (offset 0))
593 (unless (null-pointer-p (sap-ref-sap location offset))
594 (deallocate-memory (sap-ref-sap location offset))
595 (setf (sap-ref-sap location offset) (make-pointer 0)))))
597 (defmethod unbound-value ((type (eql 'string)) &rest args)
598 (declare (ignore type args))
601 (defmethod alien-type ((type (eql 'pathname)) &rest args)
602 (declare (ignore type args))
603 (alien-type 'string))
605 (defmethod size-of ((type (eql 'pathname)) &rest args)
606 (declare (ignore type args))
609 (defmethod to-alien-form (path (type (eql 'pathname)) &rest args)
610 (declare (ignore type args))
611 (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string))
613 (defmethod to-alien-function ((type (eql 'pathname)) &rest args)
614 (declare (ignore type args))
615 (let ((string-function (to-alien-function 'string)))
617 (funcall string-function (namestring path)))))
619 (defmethod from-alien-form (string (type (eql 'pathname)) &rest args)
620 (declare (ignore type args))
621 `(parse-namestring ,(from-alien-form string 'string)))
623 (defmethod from-alien-function ((type (eql 'pathname)) &rest args)
624 (declare (ignore type args))
625 (let ((string-function (from-alien-function 'string)))
627 (parse-namestring (funcall string-function string)))))
629 (defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args)
630 (declare (ignore type args))
631 (cleanup-form string 'string))
633 (defmethod cleanup-function ((type (eql 'pathnanme)) &rest args)
634 (declare (ignore type args))
635 (cleanup-function 'string))
637 (defmethod writer-function ((type (eql 'pathname)) &rest args)
638 (declare (ignore type args))
639 (let ((string-writer (writer-function 'string)))
640 #'(lambda (path location &optional (offset 0))
641 (funcall string-writer (namestring path) location offset))))
643 (defmethod reader-function ((type (eql 'pathname)) &rest args)
644 (declare (ignore type args))
645 (let ((string-reader (reader-function 'string)))
646 #'(lambda (location &optional (offset 0))
647 (let ((string (funcall string-reader location offset)))
649 (parse-namestring string))))))
651 (defmethod destroy-function ((type (eql 'pathname)) &rest args)
652 (declare (ignore type args))
653 (destroy-function 'string))
655 (defmethod unbound-value ((type (eql 'pathname)) &rest args)
656 (declare (ignore type args))
657 (unbound-value 'string))
660 (defmethod alien-type ((type (eql 'boolean)) &rest args)
661 (apply #'alien-type 'signed-byte args))
663 (defmethod size-of ((type (eql 'boolean)) &rest args)
664 (apply #'size-of 'signed-byte args))
666 (defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args)
667 (declare (ignore type args))
670 (defmethod to-alien-function ((type (eql 'boolean)) &rest args)
671 (declare (ignore type args))
675 (defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args)
676 (declare (ignore type args))
677 `(not (zerop ,boolean)))
679 (defmethod from-alien-function ((type (eql 'boolean)) &rest args)
680 (declare (ignore type args))
682 (not (zerop boolean))))
684 (defmethod writer-function ((type (eql 'boolean)) &rest args)
685 (declare (ignore type))
686 (let ((writer (apply #'writer-function 'signed-byte args)))
687 #'(lambda (boolean location &optional (offset 0))
688 (funcall writer (if boolean 1 0) location offset))))
690 (defmethod reader-function ((type (eql 'boolean)) &rest args)
691 (declare (ignore type))
692 (let ((reader (apply #'reader-function 'signed-byte args)))
693 #'(lambda (location &optional (offset 0))
694 (not (zerop (funcall reader location offset))))))
697 (defmethod alien-type ((type (eql 'or)) &rest args)
698 (let ((alien-type (alien-type (first args))))
699 (unless (every #'(lambda (type)
700 (eq alien-type (alien-type type)))
702 (error "No common alien type specifier for union type: ~A"
706 (defmethod size-of ((type (eql 'or)) &rest args)
707 (declare (ignore type))
708 (size-of (first args)))
710 (defmethod to-alien-form (form (type (eql 'or)) &rest args)
711 (declare (ignore type))
712 `(let ((value ,form))
716 `(,type ,(to-alien-form 'value type)))
719 (defmethod to-alien-function ((type (eql 'or)) &rest types)
720 (declare (ignore type))
721 (let ((functions (mapcar #'to-alien-function types)))
724 for function in functions
726 when (typep value type)
727 do (return (funcall function value))
728 finally (error "~S is not of type ~A" value `(or ,@types))))))
730 (defmethod alien-type ((type (eql 'system-area-pointer)) &rest args)
731 (declare (ignore type args))
732 'system-area-pointer)
734 (defmethod size-of ((type (eql 'system-area-pointer)) &rest args)
735 (declare (ignore type args))
738 (defmethod writer-function ((type (eql 'system-area-pointer)) &rest args)
739 (declare (ignore type args))
740 #'(lambda (sap location &optional (offset 0))
741 (setf (sap-ref-sap location offset) sap)))
743 (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
744 (declare (ignore type args))
745 #'(lambda (location &optional (offset 0))
746 (sap-ref-sap location offset)))
749 (defmethod alien-type ((type (eql 'null)) &rest args)
750 (declare (ignore type args))
751 (alien-type 'pointer))
753 (defmethod size-of ((type (eql 'null)) &rest args)
754 (declare (ignore type args))
757 (defmethod to-alien-form (null (type (eql 'null)) &rest args)
758 (declare (ignore null type args))
761 (defmethod to-alien-function ((type (eql 'null)) &rest args)
762 (declare (ignore type args))
764 (declare (ignore null))
768 (defmethod alien-type ((type (eql 'nil)) &rest args)
769 (declare (ignore type args))
772 (defmethod from-alien-function ((type (eql 'nil)) &rest args)
773 (declare (ignore type args))
775 (declare (ignore value))
779 (defmethod alien-type ((type (eql 'copy-of)) &rest args)
780 (declare (ignore type))
781 (alien-type (first args)))
783 (defmethod size-of ((type (eql 'copy-of)) &rest args)
784 (declare (ignore type))
785 (size-of (first args)))
787 (defmethod to-alien-form (form (type (eql 'copy-of)) &rest args)
788 (declare (ignore type))
789 (copy-to-alien-form form (first args)))
791 (defmethod to-alien-function ((type (eql 'copy-of)) &rest args)
792 (declare (ignore type))
793 (copy-to-alien-function (first args)))
795 (defmethod from-alien-form (form (type (eql 'copy-of)) &rest args)
796 (declare (ignore type))
797 (copy-from-alien-form form (first args)))
799 (defmethod from-alien-function ((type (eql 'copy-of)) &rest args)
800 (declare (ignore type))
801 (copy-from-alien-function (first args)))
803 (defmethod reader-function ((type (eql 'copy-of)) &rest args)
804 (declare (ignore type))
805 (reader-function (first args)))
807 (defmethod writer-function ((type (eql 'copy-of)) &rest args)
808 (declare (ignore type))
809 (writer-function (first args)))