1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
4 ;; Permission is hereby granted, free of charge, to any person obtaining
5 ;; a copy of this software and associated documentation files (the
6 ;; "Software"), to deal in the Software without restriction, including
7 ;; without limitation the rights to use, copy, modify, merge, publish,
8 ;; distribute, sublicense, and/or sell copies of the Software, and to
9 ;; permit persons to whom the Software is furnished to do so, subject to
10 ;; the following conditions:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
23 ;; $Id: ffi.lisp,v 1.20 2005-04-23 16:48:50 espen Exp $
28 ;;;; Foreign function call interface
30 (defvar *package-prefix* nil)
32 (defun set-package-prefix (prefix &optional (package *package*))
33 (let ((package (find-package package)))
34 (delete-if #'(lambda (assoc) (eq (car assoc) package)) *package-prefix*)
35 (push (cons package prefix) *package-prefix*))
38 (defun package-prefix (&optional (package *package*))
39 (let ((package (find-package package)))
41 (cdr (assoc package *package-prefix*))
42 (substitute #\_ #\- (string-downcase (package-name package))))))
44 (defun find-prefix-package (prefix)
46 (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=))
47 (find-package (string-upcase prefix))))
49 (defmacro use-prefix (prefix &optional (package *package*))
50 `(eval-when (:compile-toplevel :load-toplevel :execute)
51 (set-package-prefix ,prefix ,package)))
54 (defun default-alien-fname (lisp-name)
55 (let* ((name (substitute #\_ #\- (string-downcase lisp-name)))
59 (char= (char name 0) #\%)
60 (string= "_p" name :start2 (- (length name) 2)))
61 (subseq name 1 (- (length name) 2)))
62 ((char= (char name 0) #\%)
64 ((string= "_p" name :start2 (- (length name) 2))
65 (subseq name 0 (- (length name) 2)))
67 (prefix (package-prefix *package*)))
68 (if (or (not prefix) (string= prefix ""))
70 (format nil "~A_~A" prefix stripped-name))))
72 (defun default-alien-type-name (type-name)
73 (let ((prefix (package-prefix *package*)))
79 (cons prefix (split-string (symbol-name type-name) #\-))))))
81 (defun default-type-name (alien-name)
85 (split-string-if alien-name #'upper-case-p))))
88 (rest parts) #\-) (find-prefix-package (first parts)))))
91 (defmacro defbinding (name lambda-list return-type &rest docs/args)
92 (multiple-value-bind (lisp-name c-name)
94 (values name (default-alien-fname name))
97 (let ((supplied-lambda-list lambda-list)
100 (dolist (doc/arg docs/args)
101 (if (stringp doc/arg)
104 (destructuring-bind (expr type &optional (style :in)) doc/arg
105 (unless (member style '(:in :out :in-out :return))
106 (error "Bogus argument style ~S in ~S." style doc/arg))
108 (not supplied-lambda-list)
109 (namep expr) (member style '(:in :in-out :return)))
110 (push expr lambda-list))
112 ((and (namep expr) (eq style :out)) expr)
113 ((namep expr) (make-symbol (string expr)))
115 expr (mklist type) style) args)))))
118 c-name lisp-name (or supplied-lambda-list (nreverse lambda-list))
119 return-type (reverse docs) (reverse args)))))
122 (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args)
123 (collect ((alien-types) (alien-bindings) (alien-parameters)
124 (return-values) (cleanup-forms))
126 (destructuring-bind (var expr type style) arg
127 (let ((declaration (alien-type type))
128 (cleanup (cleanup-form var type)))
131 ((member style '(:out :in-out))
132 (alien-types `(* ,declaration))
133 (alien-parameters `(addr ,var))
137 ((eq style :in-out) (list (to-alien-form expr type)))
138 ((eq declaration 'system-area-pointer)
139 (list '(make-pointer 0))))))
140 (return-values (from-alien-form var type)))
142 (alien-types declaration)
144 `(,var ,declaration ,(to-alien-form expr type)))
145 (alien-parameters var)
146 (return-values (from-alien-form var type)))
148 (alien-types declaration)
150 `(,var ,declaration ,(to-alien-form expr type)))
151 (alien-parameters var)
152 (cleanup-forms cleanup))
154 (alien-types declaration)
155 (alien-parameters (to-alien-form expr type)))))))
157 (let* ((alien-name (make-symbol (string lisp-name)))
158 (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters))))
159 `(defun ,lisp-name ,lambda-list
161 #+cmu(declare (optimize (inhibit-warnings 3)))
162 #+sbcl(declare (muffle-conditions compiler-note))
163 (with-alien ((,alien-name
165 ,(alien-type return-type)
167 :extern ,foreign-name)
172 ,(from-alien-form alien-funcall return-type)
179 (values ,@(return-values)))))))))
182 ;;; Creates bindings at runtime
183 (defun mkbinding (name return-type &rest arg-types)
184 #+cmu(declare (optimize (inhibit-warnings 3)))
185 #+sbcl(declare (muffle-conditions compiler-note))
187 `(function ,@(mapcar #'alien-type (cons return-type arg-types))))
190 (make-heap-alien-info
191 :type (parse-alien-type ftype #+sbcl nil)
192 :sap-form (foreign-symbol-address name))))
193 (translate-arguments (mapcar #'to-alien-function arg-types))
194 (translate-return-value (from-alien-function return-type))
195 (cleanup-arguments (mapcar #'cleanup-function arg-types)))
197 #'(lambda (&rest args)
198 (map-into args #'funcall translate-arguments args)
200 (funcall translate-return-value
201 (apply #'alien-funcall alien args))
202 (mapc #'funcall cleanup-arguments args)))))
205 (defmacro defcallback (name (return-type &rest args) &body body)
206 (let ((def-callback #+cmu'alien:def-callback
207 #+sbcl'sb-alien:define-alien-function))
208 `(,def-callback ,name
209 (,(alien-type return-type)
210 ,@(mapcar #'(lambda (arg)
211 (destructuring-bind (name type) arg
212 `(,name ,(alien-type type))))
216 (mapcar #'(lambda (arg)
217 (destructuring-bind (name type) arg
219 (from-alien-form name type)))
220 (unless (eq name from-alien)
221 `(,name ,from-alien)))))
228 (sb-alien:alien-function-sap af))
231 (deftype callback () 'sb-alien:alien-function)
233 ;;;; Definitons and translations of fundamental types
235 (defmacro def-type-method (name args &optional documentation)
237 (defgeneric ,name (,@args type &rest args)
238 ,@(when documentation `((:documentation ,documentation))))
239 (defmethod ,name (,@args (type symbol) &rest args)
240 (let ((class (find-class type nil)))
242 (apply #',name ,@args class args)
243 (multiple-value-bind (super-type expanded-p)
244 (type-expand-1 (cons type args))
246 (,name ,@args super-type)
247 (call-next-method))))))
248 (defmethod ,name (,@args (type cons) &rest args)
249 (declare (ignore args))
250 (apply #',name ,@args (first type) (rest type)))))
253 (def-type-method alien-type ())
254 (def-type-method size-of ())
255 (def-type-method to-alien-form (form))
256 (def-type-method from-alien-form (form))
257 (def-type-method cleanup-form (form)
258 "Creates a form to clean up after the alien call has finished.")
260 (def-type-method to-alien-function ())
261 (def-type-method from-alien-function ())
262 (def-type-method cleanup-function ())
264 (def-type-method copy-to-alien-form (form))
265 (def-type-method copy-to-alien-function ())
266 (def-type-method copy-from-alien-form (form))
267 (def-type-method copy-from-alien-function ())
269 (def-type-method writer-function ())
270 (def-type-method reader-function ())
271 (def-type-method destroy-function ())
273 (def-type-method unbound-value ()
274 "First return value is true if the type has an unbound value, second return value is the actual unbound value")
277 ;; Sizes of fundamental C types in bytes (8 bits)
278 (defconstant +size-of-short+ 2)
279 (defconstant +size-of-int+ 4)
280 (defconstant +size-of-long+ 4)
281 (defconstant +size-of-pointer+ 4)
282 (defconstant +size-of-float+ 4)
283 (defconstant +size-of-double+ 8)
285 ;; Sizes of fundamental C types in bits
286 (defconstant +bits-of-byte+ 8)
287 (defconstant +bits-of-short+ 16)
288 (defconstant +bits-of-int+ 32)
289 (defconstant +bits-of-long+ 32)
292 (deftype int () '(signed-byte #.+bits-of-int+))
293 (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+))
294 (deftype long () '(signed-byte #.+bits-of-long+))
295 (deftype unsigned-long () '(unsigned-byte #.+bits-of-long+))
296 (deftype short () '(signed-byte #.+bits-of-short+))
297 (deftype unsigned-short () '(unsigned-byte #.+bits-of-short+))
298 (deftype signed (&optional (size '*)) `(signed-byte ,size))
299 (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
300 (deftype char () 'base-char)
301 (deftype pointer () 'system-area-pointer)
302 (deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil))
303 ;(deftype invalid () nil)
306 (defmethod to-alien-form (form (type t) &rest args)
307 (declare (ignore type args))
310 (defmethod to-alien-function ((type t) &rest args)
311 (declare (ignore type args))
314 (defmethod from-alien-form (form (type t) &rest args)
315 (declare (ignore type args))
318 (defmethod from-alien-function ((type t) &rest args)
319 (declare (ignore type args))
322 (defmethod cleanup-form (form (type t) &rest args)
323 (declare (ignore form type args))
326 (defmethod cleanup-function ((type t) &rest args)
327 (declare (ignore type args))
330 (defmethod destroy-function ((type t) &rest args)
331 (declare (ignore type args))
332 #'(lambda (location &optional offset)
333 (declare (ignore location offset))))
335 (defmethod copy-to-alien-form (form (type t) &rest args)
336 (apply #'to-alien-form form type args))
338 (defmethod copy-to-alien-function ((type t) &rest args)
339 (apply #'to-alien-function type args))
341 (defmethod copy-from-alien-form (form (type t) &rest args)
342 (apply #'from-alien-form form type args))
344 (defmethod copy-from-alien-function ((type t) &rest args)
345 (apply #'from-alien-function type args))
348 (defmethod alien-type ((type (eql 'signed-byte)) &rest args)
349 (declare (ignore type))
350 (destructuring-bind (&optional (size '*)) args
352 (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8))
353 (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short)
354 ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int)
355 (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long))))
357 (defmethod size-of ((type (eql 'signed-byte)) &rest args)
358 (declare (ignore type))
359 (destructuring-bind (&optional (size '*)) args
362 (#.+bits-of-short+ +size-of-short+)
363 ((* #.+bits-of-int+) +size-of-int+)
364 (#.+bits-of-long+ +size-of-long+))))
366 (defmethod unbound-value ((type t) &rest args)
367 (declare (ignore type args))
370 (defmethod writer-function ((type (eql 'signed-byte)) &rest args)
371 (declare (ignore type))
372 (destructuring-bind (&optional (size '*)) args
373 (let ((size (if (eq size '*) +bits-of-int+ size)))
375 (8 #'(lambda (value location &optional (offset 0))
376 (setf (signed-sap-ref-8 location offset) value)))
377 (16 #'(lambda (value location &optional (offset 0))
378 (setf (signed-sap-ref-16 location offset) value)))
379 (32 #'(lambda (value location &optional (offset 0))
380 (setf (signed-sap-ref-32 location offset) value)))
381 (64 #'(lambda (value location &optional (offset 0))
382 (setf (signed-sap-ref-64 location offset) value)))))))
384 (defmethod reader-function ((type (eql 'signed-byte)) &rest args)
385 (declare (ignore type))
386 (destructuring-bind (&optional (size '*)) args
387 (let ((size (if (eq size '*) +bits-of-int+ size)))
389 (8 #'(lambda (sap &optional (offset 0))
390 (signed-sap-ref-8 sap offset)))
391 (16 #'(lambda (sap &optional (offset 0))
392 (signed-sap-ref-16 sap offset)))
393 (32 #'(lambda (sap &optional (offset 0))
394 (signed-sap-ref-32 sap offset)))
395 (64 #'(lambda (sap &optional (offset 0))
396 (signed-sap-ref-64 sap offset)))))))
398 (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)
399 (destructuring-bind (&optional (size '*)) args
401 (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8))
402 (#.+bits-of-short+ #+cmu 'c-call:unsigned-short
403 #+sbcl 'sb-alien:unsigned-short)
404 ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int
405 #+sbcl 'sb-alien:unsigned-int)
406 (#.+bits-of-long+ #+cmu 'c-call:unsigned-long
407 #+sbcl 'sb-alien:unsigned-long))))
409 (defmethod size-of ((type (eql 'unsigned-byte)) &rest args)
410 (apply #'size-of 'signed args))
412 (defmethod writer-function ((type (eql 'unsigned-byte)) &rest args)
413 (declare (ignore type))
414 (destructuring-bind (&optional (size '*)) args
415 (let ((size (if (eq size '*) +bits-of-int+ size)))
417 (8 #'(lambda (value location &optional (offset 0))
418 (setf (sap-ref-8 location offset) value)))
419 (16 #'(lambda (value location &optional (offset 0))
420 (setf (sap-ref-16 location offset) value)))
421 (32 #'(lambda (value location &optional (offset 0))
422 (setf (sap-ref-32 location offset) value)))
423 (64 #'(lambda (value location &optional (offset 0))
424 (setf (sap-ref-64 location offset) value)))))))
426 (defmethod reader-function ((type (eql 'unsigned-byte)) &rest args)
427 (declare (ignore type))
428 (destructuring-bind (&optional (size '*)) args
429 (let ((size (if (eq size '*) +bits-of-int+ size)))
431 (8 #'(lambda (sap &optional (offset 0))
432 (sap-ref-8 sap offset)))
433 (16 #'(lambda (sap &optional (offset 0))
434 (sap-ref-16 sap offset)))
435 (32 #'(lambda (sap &optional (offset 0))
436 (sap-ref-32 sap offset)))
437 (64 #'(lambda (sap &optional (offset 0))
438 (sap-ref-64 sap offset)))))))
441 (defmethod alien-type ((type (eql 'integer)) &rest args)
442 (declare (ignore type args))
443 (alien-type 'signed-byte))
445 (defmethod size-of ((type (eql 'integer)) &rest args)
446 (declare (ignore type args))
447 (size-of 'signed-byte))
449 (defmethod writer-function ((type (eql 'integer)) &rest args)
450 (declare (ignore type args))
451 (writer-function 'signed-byte))
453 (defmethod reader-function ((type (eql 'integer)) &rest args)
454 (declare (ignore type args))
455 (reader-function 'signed-byte))
458 (defmethod alien-type ((type (eql 'fixnum)) &rest args)
459 (declare (ignore type args))
460 (alien-type 'signed-byte))
462 (defmethod size-of ((type (eql 'fixnum)) &rest args)
463 (declare (ignore type args))
464 (size-of 'signed-byte))
467 (defmethod alien-type ((type (eql 'single-float)) &rest args)
468 (declare (ignore type args))
469 #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float)
471 (defmethod size-of ((type (eql 'single-float)) &rest args)
472 (declare (ignore type args))
475 (defmethod to-alien-form (form (type (eql 'single-float)) &rest args)
476 (declare (ignore type args))
477 `(coerce ,form 'single-float))
479 (defmethod to-alien-function ((type (eql 'single-float)) &rest args)
480 (declare (ignore type args))
482 (coerce number 'single-float)))
484 (defmethod writer-function ((type (eql 'single-float)) &rest args)
485 (declare (ignore type args))
486 #'(lambda (value location &optional (offset 0))
487 (setf (sap-ref-single location offset) (coerce value 'single-float))))
489 (defmethod reader-function ((type (eql 'single-float)) &rest args)
490 (declare (ignore type args))
491 #'(lambda (sap &optional (offset 0))
492 (sap-ref-single sap offset)))
495 (defmethod alien-type ((type (eql 'double-float)) &rest args)
496 (declare (ignore type args))
497 #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float)
499 (defmethod size-of ((type (eql 'double-float)) &rest args)
500 (declare (ignore type args))
503 (defmethod to-alien-form (form (type (eql 'double-float)) &rest args)
504 (declare (ignore type args))
505 `(coerce ,form 'double-float))
507 (defmethod to-alien-function ((type (eql 'double-float)) &rest args)
508 (declare (ignore type args))
510 (coerce number 'double-float)))
512 (defmethod writer-function ((type (eql 'double-float)) &rest args)
513 (declare (ignore type args))
514 #'(lambda (value location &optional (offset 0))
515 (setf (sap-ref-double location offset) (coerce value 'double-float))))
517 (defmethod reader-function ((type (eql 'double-float)) &rest args)
518 (declare (ignore type args))
519 #'(lambda (sap &optional (offset 0))
520 (sap-ref-double sap offset)))
523 (defmethod alien-type ((type (eql 'base-char)) &rest args)
524 (declare (ignore type args))
525 #+cmu 'c-call:char #+sbcl 'sb-alien:char)
527 (defmethod size-of ((type (eql 'base-char)) &rest args)
528 (declare (ignore type args))
531 (defmethod writer-function ((type (eql 'base-char)) &rest args)
532 (declare (ignore type args))
533 #'(lambda (char location &optional (offset 0))
534 (setf (sap-ref-8 location offset) (char-code char))))
536 (defmethod reader-function ((type (eql 'base-char)) &rest args)
537 (declare (ignore type args))
538 #'(lambda (location &optional (offset 0))
539 (code-char (sap-ref-8 location offset))))
542 (defmethod alien-type ((type (eql 'string)) &rest args)
543 (declare (ignore type args))
544 (alien-type 'pointer))
546 (defmethod size-of ((type (eql 'string)) &rest args)
547 (declare (ignore type args))
550 (defmethod to-alien-form (string (type (eql 'string)) &rest args)
551 (declare (ignore type args))
552 `(let ((string ,string))
553 ;; Always copy strings to prevent seg fault due to GC
556 (vector-sap (coerce string 'simple-base-string))
557 (1+ (length string)))
559 (let ((utf8 (%deport-utf8-string string)))
560 (copy-memory (vector-sap utf8) (length utf8)))))
562 (defmethod to-alien-function ((type (eql 'string)) &rest args)
563 (declare (ignore type args))
567 (vector-sap (coerce string 'simple-base-string))
568 (1+ (length string)))
570 (let ((utf8 (%deport-utf8-string string)))
571 (copy-memory (vector-sap utf8) (length utf8)))))
573 (defmethod from-alien-form (string (type (eql 'string)) &rest args)
574 (declare (ignore type args))
575 `(let ((string ,string))
576 (unless (null-pointer-p string)
578 #+cmu(%naturalize-c-string string)
579 #+sbcl(%naturalize-utf8-string string)
580 (deallocate-memory string)))))
582 (defmethod from-alien-function ((type (eql 'string)) &rest args)
583 (declare (ignore type args))
585 (unless (null-pointer-p string)
587 #+cmu(%naturalize-c-string string)
588 #+sbcl(%naturalize-utf8-string string)
589 (deallocate-memory string)))))
591 (defmethod cleanup-form (string (type (eql 'string)) &rest args)
592 (declare (ignore type args))
593 `(let ((string ,string))
594 (unless (null-pointer-p string)
595 (deallocate-memory string))))
597 (defmethod cleanup-function ((type (eql 'string)) &rest args)
598 (declare (ignore args))
600 (unless (null-pointer-p string)
601 (deallocate-memory string))))
603 (defmethod copy-from-alien-form (string (type (eql 'string)) &rest args)
604 (declare (ignore type args))
605 `(let ((string ,string))
606 (unless (null-pointer-p string)
607 #+cmu(%naturalize-c-string string)
608 #+sbcl(%naturalize-utf8-string string))))
610 (defmethod copy-from-alien-function ((type (eql 'string)) &rest args)
611 (declare (ignore type args))
613 (unless (null-pointer-p string)
614 #+cmu(%naturalize-c-string string)
615 #+sbcl(%naturalize-utf8-string string))))
617 (defmethod writer-function ((type (eql 'string)) &rest args)
618 (declare (ignore type args))
619 #'(lambda (string location &optional (offset 0))
620 (assert (null-pointer-p (sap-ref-sap location offset)))
621 (setf (sap-ref-sap location offset)
624 (vector-sap (coerce string 'simple-base-string))
625 (1+ (length string)))
627 (let ((utf8 (%deport-utf8-string string)))
628 (copy-memory (vector-sap utf8) (length utf8))))))
630 (defmethod reader-function ((type (eql 'string)) &rest args)
631 (declare (ignore type args))
632 #'(lambda (location &optional (offset 0))
633 (unless (null-pointer-p (sap-ref-sap location offset))
634 #+cmu(%naturalize-c-string (sap-ref-sap location offset))
635 #+sbcl(%naturalize-utf8-string (sap-ref-sap location offset)))))
637 (defmethod destroy-function ((type (eql 'string)) &rest args)
638 (declare (ignore type args))
639 #'(lambda (location &optional (offset 0))
640 (unless (null-pointer-p (sap-ref-sap location offset))
641 (deallocate-memory (sap-ref-sap location offset))
642 (setf (sap-ref-sap location offset) (make-pointer 0)))))
644 (defmethod unbound-value ((type (eql 'string)) &rest args)
645 (declare (ignore type args))
649 (defmethod alien-type ((type (eql 'pathname)) &rest args)
650 (declare (ignore type args))
651 (alien-type 'string))
653 (defmethod size-of ((type (eql 'pathname)) &rest args)
654 (declare (ignore type args))
657 (defmethod to-alien-form (path (type (eql 'pathname)) &rest args)
658 (declare (ignore type args))
659 (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string))
661 (defmethod to-alien-function ((type (eql 'pathname)) &rest args)
662 (declare (ignore type args))
663 (let ((string-function (to-alien-function 'string)))
665 (funcall string-function (namestring path)))))
667 (defmethod from-alien-form (string (type (eql 'pathname)) &rest args)
668 (declare (ignore type args))
669 `(parse-namestring ,(from-alien-form string 'string)))
671 (defmethod from-alien-function ((type (eql 'pathname)) &rest args)
672 (declare (ignore type args))
673 (let ((string-function (from-alien-function 'string)))
675 (parse-namestring (funcall string-function string)))))
677 (defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args)
678 (declare (ignore type args))
679 (cleanup-form string 'string))
681 (defmethod cleanup-function ((type (eql 'pathnanme)) &rest args)
682 (declare (ignore type args))
683 (cleanup-function 'string))
685 (defmethod writer-function ((type (eql 'pathname)) &rest args)
686 (declare (ignore type args))
687 (let ((string-writer (writer-function 'string)))
688 #'(lambda (path location &optional (offset 0))
689 (funcall string-writer (namestring path) location offset))))
691 (defmethod reader-function ((type (eql 'pathname)) &rest args)
692 (declare (ignore type args))
693 (let ((string-reader (reader-function 'string)))
694 #'(lambda (location &optional (offset 0))
695 (let ((string (funcall string-reader location offset)))
697 (parse-namestring string))))))
699 (defmethod destroy-function ((type (eql 'pathname)) &rest args)
700 (declare (ignore type args))
701 (destroy-function 'string))
703 (defmethod unbound-value ((type (eql 'pathname)) &rest args)
704 (declare (ignore type args))
705 (unbound-value 'string))
708 (defmethod alien-type ((type (eql 'boolean)) &rest args)
709 (apply #'alien-type 'signed-byte args))
711 (defmethod size-of ((type (eql 'boolean)) &rest args)
712 (apply #'size-of 'signed-byte args))
714 (defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args)
715 (declare (ignore type args))
718 (defmethod to-alien-function ((type (eql 'boolean)) &rest args)
719 (declare (ignore type args))
723 (defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args)
724 (declare (ignore type args))
725 `(not (zerop ,boolean)))
727 (defmethod from-alien-function ((type (eql 'boolean)) &rest args)
728 (declare (ignore type args))
730 (not (zerop boolean))))
732 (defmethod writer-function ((type (eql 'boolean)) &rest args)
733 (declare (ignore type))
734 (let ((writer (apply #'writer-function 'signed-byte args)))
735 #'(lambda (boolean location &optional (offset 0))
736 (funcall writer (if boolean 1 0) location offset))))
738 (defmethod reader-function ((type (eql 'boolean)) &rest args)
739 (declare (ignore type))
740 (let ((reader (apply #'reader-function 'signed-byte args)))
741 #'(lambda (location &optional (offset 0))
742 (not (zerop (funcall reader location offset))))))
745 (defmethod alien-type ((type (eql 'or)) &rest args)
746 (let ((alien-type (alien-type (first args))))
747 (unless (every #'(lambda (type)
748 (eq alien-type (alien-type type)))
750 (error "No common alien type specifier for union type: ~A"
754 (defmethod size-of ((type (eql 'or)) &rest args)
755 (declare (ignore type))
756 (size-of (first args)))
758 (defmethod to-alien-form (form (type (eql 'or)) &rest args)
759 (declare (ignore type))
760 `(let ((value ,form))
764 `(,type ,(to-alien-form 'value type)))
767 (defmethod to-alien-function ((type (eql 'or)) &rest types)
768 (declare (ignore type))
769 (let ((functions (mapcar #'to-alien-function types)))
772 for function in functions
774 when (typep value type)
775 do (return (funcall function value))
776 finally (error "~S is not of type ~A" value `(or ,@types))))))
778 (defmethod alien-type ((type (eql 'system-area-pointer)) &rest args)
779 (declare (ignore type args))
780 'system-area-pointer)
782 (defmethod size-of ((type (eql 'system-area-pointer)) &rest args)
783 (declare (ignore type args))
786 (defmethod writer-function ((type (eql 'system-area-pointer)) &rest args)
787 (declare (ignore type args))
788 #'(lambda (sap location &optional (offset 0))
789 (setf (sap-ref-sap location offset) sap)))
791 (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
792 (declare (ignore type args))
793 #'(lambda (location &optional (offset 0))
794 (sap-ref-sap location offset)))
797 (defmethod alien-type ((type (eql 'null)) &rest args)
798 (declare (ignore type args))
799 (alien-type 'pointer))
801 (defmethod size-of ((type (eql 'null)) &rest args)
802 (declare (ignore type args))
805 (defmethod to-alien-form (null (type (eql 'null)) &rest args)
806 (declare (ignore null type args))
809 (defmethod to-alien-function ((type (eql 'null)) &rest args)
810 (declare (ignore type args))
812 (declare (ignore null))
816 (defmethod alien-type ((type (eql 'nil)) &rest args)
817 (declare (ignore type args))
820 (defmethod from-alien-function ((type (eql 'nil)) &rest args)
821 (declare (ignore type args))
823 (declare (ignore value))
827 (defmethod alien-type ((type (eql 'copy-of)) &rest args)
828 (declare (ignore type))
829 (alien-type (first args)))
831 (defmethod size-of ((type (eql 'copy-of)) &rest args)
832 (declare (ignore type))
833 (size-of (first args)))
835 (defmethod to-alien-form (form (type (eql 'copy-of)) &rest args)
836 (declare (ignore type))
837 (copy-to-alien-form form (first args)))
839 (defmethod to-alien-function ((type (eql 'copy-of)) &rest args)
840 (declare (ignore type))
841 (copy-to-alien-function (first args)))
843 (defmethod from-alien-form (form (type (eql 'copy-of)) &rest args)
844 (declare (ignore type))
845 (copy-from-alien-form form (first args)))
847 (defmethod from-alien-function ((type (eql 'copy-of)) &rest args)
848 (declare (ignore type))
849 (copy-from-alien-function (first args)))
851 (defmethod reader-function ((type (eql 'copy-of)) &rest args)
852 (declare (ignore type))
853 (reader-function (first args)))
855 (defmethod writer-function ((type (eql 'copy-of)) &rest args)
856 (declare (ignore type))
857 (writer-function (first args)))
860 (defmethod alien-type ((type (eql 'callback)) &rest args)
861 (declare (ignore type args))
862 (alien-type 'pointer))
864 (defmethod size-of ((type (eql 'callback)) &rest args)
865 (declare (ignore type args))
868 (defmethod to-alien-form (callback (type (eql 'callback)) &rest args)
869 (declare (ignore type args))
870 #+cmu `(callback ,callback)
871 #+sbcl `(sb-alien:alien-function-sap ,callback))
873 (defmethod to-alien-function ((type (eql 'callback)) &rest args)
874 (declare (ignore type args))
875 #+cmu #'(lambda (callback) (callback callback))
876 #+sbcl #'sb-alien:alien-function-sap)
879 (defun find-callback (pointer)
880 (find pointer alien::*callbacks* :key #'callback-trampoline :test #'sap=))
882 (defmethod from-alien-form (pointer (type (eql 'callback)) &rest args)
883 (declare (ignore type args))
884 #+cmu `(find-callback ,pointer)
885 #+sbcl `(sb-alien::%find-alien-function ,pointer))
887 (defmethod from-alien-function ((type (eql 'callback)) &rest args)
888 (declare (ignore type args))
889 #+cmu #'find-callback
890 #+sbcl #'sb-alien::%find-alien-function)
892 (defmethod writer-function ((type (eql 'callback)) &rest args)
893 (declare (ignore type args))
894 (let ((writer (writer-function 'pointer))
895 (to-alien (to-alien-function 'callback)))
896 #'(lambda (callback location &optional (offset 0))
897 (funcall writer (funcall to-alien callback) location offset))))
899 (defmethod reader-function ((type (eql 'callback)) &rest args)
900 (declare (ignore type args))
901 (let ((reader (reader-function 'pointer))
902 (from-alien (from-alien-function 'callback)))
903 #'(lambda (location &optional (offset 0))
904 (let ((pointer (funcall reader location offset)))
905 (unless (null-pointer-p pointer)
906 (funcall from-alien pointer))))))
908 (defmethod unbound-value ((type (eql 'callback)) &rest args)
909 (declare (ignore type args))