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.1 2004/10/27 14:46:01 espen Exp $
24 (defvar *type-methods* (make-hash-table))
26 (defun ensure-type-method-fun (fname)
27 (unless (fboundp fname)
29 (symbol-function fname)
30 #'(lambda (type-spec &rest args)
32 (find-applicable-type-method type-spec fname) type-spec args)))))
34 (defmacro define-type-method-fun (fname lambda-list)
35 (declare (ignore lambda-list))
36 `(defun ,fname (type-spec &rest args)
38 (find-applicable-type-method type-spec ',fname) type-spec args)))
41 (defun ensure-type-name (type)
44 (pcl::class (class-name type))))
46 (defun add-type-method (type fname function)
49 (gethash (ensure-type-name type) *type-methods*)))
51 (defun find-type-method (type fname)
52 (cdr (assoc fname (gethash (ensure-type-name type) *type-methods*))))
54 (defun find-applicable-type-method (type-spec fname &optional (error t))
55 (flet ((find-superclass-method (class)
56 (when (and class (class-finalized-p class))
57 ; (unless (class-finalized-p class)
58 ; (finalize-inheritance class))
59 (dolist (super (cdr (pcl::class-precedence-list class)))
60 (return-if (find-type-method super fname)))))
61 (find-expanded-type-method (type-spec)
62 (multiple-value-bind (expanded-type-spec expanded-p)
63 (type-expand-1 type-spec)
66 (find-applicable-type-method expanded-type-spec fname nil))
68 (find-applicable-type-method t fname nil))))))
74 (find-type-method type-spec fname)
75 (find-superclass-method type-spec)))
78 (find-type-method type-spec fname)
79 (find-expanded-type-method type-spec)
80 (find-superclass-method (find-class type-spec nil))))
83 (find-type-method (first type-spec) fname)
84 (find-expanded-type-method type-spec)))
86 (error "Invalid type specifier ~A" type-spec)))
90 "No applicable method for ~A when called with type specifier ~A"
93 (defmacro deftype-method (fname type lambda-list &body body)
95 (ensure-type-method-fun ',fname)
96 (add-type-method ',type ',fname #'(lambda ,lambda-list ,@body))
99 ;; To make the compiler happy
100 (eval-when (:compile-toplevel :load-toplevel :execute)
101 (define-type-method-fun translate-type-spec (type-spec))
102 (define-type-method-fun size-of (type-spec))
103 (define-type-method-fun translate-to-alien (type-spec expr &optional weak-ref))
104 (define-type-method-fun translate-from-alien (type-spec expr &optional weak-ref))
105 (define-type-method-fun cleanup-alien (type-spec sap &otional weak-ref))
106 (define-type-method-fun unreference-alien (type-spec sap)))
111 (defvar *type-function-cache* (make-hash-table :test #'equal))
113 (defun get-cached-function (type-spec fname)
114 (cdr (assoc fname (gethash type-spec *type-function-cache*))))
116 (defun set-cached-function (type-spec fname function)
117 (push (cons fname function) (gethash type-spec *type-function-cache*))
121 (defun intern-argument-translator (type-spec)
123 (get-cached-function type-spec 'argument-translator)
124 (set-cached-function type-spec 'argument-translator
128 (declare (ignorable object))
129 ,(translate-to-alien type-spec 'object t))))))
131 (defun intern-return-value-translator (type-spec)
133 (get-cached-function type-spec 'return-value-translator)
134 (set-cached-function type-spec 'return-value-translator
138 (declare (ignorable alien))
139 ,(translate-from-alien type-spec 'alien nil))))))
141 (defun intern-cleanup-function (type-spec)
143 (get-cached-function type-spec 'cleanup-function)
144 (set-cached-function type-spec 'cleanup-function
148 (declare (ignorable alien))
149 ,(cleanup-alien type-spec 'alien t))))))
153 ;; Returns a function to write an object of the specified type
154 ;; to a memory location
155 (defun intern-writer-function (type-spec)
157 (get-cached-function type-spec 'writer-function)
158 (set-cached-function type-spec 'writer-function
161 `(lambda (value sap offset)
162 (declare (ignorable value sap offset))
164 (,(sap-ref-fname type-spec) sap offset)
165 ,(translate-to-alien type-spec 'value nil)))))))
167 ;; Returns a function to read an object of the specified type
168 ;; from a memory location
169 (defun intern-reader-function (type-spec)
171 (get-cached-function type-spec 'reader-function)
172 (set-cached-function type-spec 'reader-function
175 `(lambda (sap offset)
176 (declare (ignorable sap offset))
177 ,(translate-from-alien
178 type-spec `(,(sap-ref-fname type-spec) sap offset) t))))))
180 (defun intern-destroy-function (type-spec)
181 (if (atomic-type-p type-spec)
182 #'(lambda (sap offset)
183 (declare (ignore sap offset)))
185 (get-cached-function type-spec 'destroy-function)
186 (set-cached-function type-spec 'destroy-function
189 `(lambda (sap offset)
190 (declare (ignorable sap offset))
192 type-spec `(,(sap-ref-fname type-spec) sap offset))))))))
198 (defconstant +bits-per-unit+ 8
199 "Number of bits in an addressable unit (byte)")
201 ;; Sizes of fundamental C types in addressable units
202 (defconstant +size-of-short+ 2)
203 (defconstant +size-of-int+ 4)
204 (defconstant +size-of-long+ 4)
205 (defconstant +size-of-sap+ 4)
206 (defconstant +size-of-float+ 4)
207 (defconstant +size-of-double+ 8)
209 (defun sap-ref-unsigned (sap offset)
210 (sap-ref-32 sap offset))
212 (defun sap-ref-signed (sap offset)
213 (signed-sap-ref-32 sap offset))
215 (defun sap-ref-fname (type-spec)
216 (let ((alien-type-spec (mklist (translate-type-spec type-spec))))
217 (ecase (first alien-type-spec)
219 (ecase (second alien-type-spec)
225 (ecase (second alien-type-spec)
226 (8 'signed-sap-ref-8)
227 (16 'signed-sap-ref-16)
228 (32 'signed-sap-ref-32)
229 (64 'signed-sap-ref-64)))
230 (system-area-pointer 'sap-ref-sap)
231 (single-float 'sap-ref-single)
232 (double-float 'sap-ref-double))))
235 ;;;; Foreign function call interface
237 (defvar *package-prefix* nil)
239 (defun set-package-prefix (prefix &optional (package *package*))
240 (let ((package (find-package package)))
241 (delete-if #'(lambda (assoc) (eq (car assoc) package)) *package-prefix*)
242 (push (cons package prefix) *package-prefix*))
245 (defun package-prefix (&optional (package *package*))
246 (let ((package (find-package package)))
248 (cdr (assoc package *package-prefix*))
249 (substitute #\_ #\- (string-downcase (package-name package))))))
251 (defun find-prefix-package (prefix)
253 (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=))
254 (find-package (string-upcase prefix))))
256 (defmacro use-prefix (prefix &optional (package *package*))
257 `(eval-when (:compile-toplevel :load-toplevel :execute)
258 (set-package-prefix ,prefix ,package)))
261 (defun default-alien-fname (lisp-name)
262 (let* ((lisp-name-string
263 (if (char= (char (the simple-string (string lisp-name)) 0) #\%)
264 (subseq (the simple-string (string lisp-name)) 1)
266 (prefix (package-prefix *package*))
267 (name (substitute #\_ #\- (string-downcase lisp-name-string))))
268 (if (or (not prefix) (string= prefix ""))
270 (format nil "~A_~A" prefix name))))
272 (defun default-alien-type-name (type-name)
273 (let ((prefix (package-prefix *package*)))
279 (cons prefix (split-string (symbol-name type-name) #\-))))))
281 (defun default-type-name (alien-name)
285 (split-string-if alien-name #'upper-case-p))))
288 (rest parts) #\-) (find-prefix-package (first parts)))))
291 (defmacro defbinding (name lambda-list return-type-spec &rest docs/args)
292 (multiple-value-bind (lisp-name c-name)
294 (values name (default-alien-fname name))
297 (let ((supplied-lambda-list lambda-list)
300 (dolist (doc/arg docs/args)
301 (if (stringp doc/arg)
304 (destructuring-bind (expr type &optional (style :in)) doc/arg
305 (unless (member style '(:in :out :in-out))
306 (error "Bogus argument style ~S in ~S." style doc/arg))
308 (not supplied-lambda-list)
309 (namep expr) (member style '(:in :in-out)))
310 (push expr lambda-list))
312 (list (if (namep expr) (make-symbol (string expr)) (gensym)) expr type style) args)))))
315 c-name lisp-name (or supplied-lambda-list (nreverse lambda-list))
316 return-type-spec (reverse docs) (reverse args)))))
319 (defun %defbinding (foreign-name lisp-name lambda-list
320 return-type-spec docs args)
321 (ext:collect ((alien-types) (alien-bindings) (alien-parameters)
322 (alien-values) (alien-deallocators))
324 (destructuring-bind (var expr type-spec style) arg
325 (let ((declaration (translate-type-spec type-spec))
326 (deallocation (cleanup-alien type-spec var t)))
328 ((member style '(:out :in-out))
329 (alien-types `(* ,declaration))
330 (alien-parameters `(addr ,var))
333 ,@(when (eq style :in-out)
334 (list (translate-to-alien type-spec expr t)))))
335 (alien-values (translate-from-alien type-spec var nil)))
337 (alien-types declaration)
339 `(,var ,declaration ,(translate-to-alien type-spec expr t)))
340 (alien-parameters var)
341 (alien-deallocators deallocation))
343 (alien-types declaration)
344 (alien-parameters (translate-to-alien type-spec expr t)))))))
346 (let* ((alien-name (make-symbol (string lisp-name)))
347 (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters))))
348 `(defun ,lisp-name ,lambda-list
350 (declare (optimize (ext:inhibit-warnings 3)))
351 (with-alien ((,alien-name
353 ,(translate-type-spec return-type-spec)
355 :extern ,foreign-name)
357 ,(if return-type-spec
359 ,(translate-from-alien return-type-spec alien-funcall nil)))
360 ,@(alien-deallocators)
361 (values result ,@(alien-values)))
364 ,@(alien-deallocators)
365 (values ,@(alien-values)))))))))
368 (defun mkbinding (name return-type &rest arg-types)
369 (declare (optimize (ext:inhibit-warnings 3)))
372 ,@(mapcar #'translate-type-spec (cons return-type arg-types))))
375 (alien::make-heap-alien-info
376 :type (alien::parse-alien-type ftype)
377 :sap-form (system:foreign-symbol-address name :flavor :code))))
379 (mapcar #'intern-argument-translator arg-types))
380 (translate-return-value (intern-return-value-translator return-type))
381 (cleanup-arguments (mapcar #'intern-cleanup-function arg-types)))
383 #'(lambda (&rest args)
384 (map-into args #'funcall translate-arguments args)
387 translate-return-value (apply #'alien:alien-funcall alien args))
388 (mapc #'funcall cleanup-arguments args)))))
391 (defun type-translateable-p (type-spec)
392 (find-applicable-type-method type-spec 'translate-type-spec nil))
394 (defun every-type-translateable-p (type-specs)
395 (every #'type-translateable-p type-specs))
397 (defun mkbinding-late (name return-type &rest arg-types)
398 (if (every-type-translateable-p (cons return-type arg-types))
399 (apply #'mkbinding name return-type arg-types)
401 #'(lambda (&rest args)
403 (binding (apply binding args))
404 ((every-type-translateable-p (cons return-type arg-types))
405 (setq binding (apply #'mkbinding name return-type arg-types))
406 (apply binding args))
408 (dolist (type-spec (cons return-type arg-types))
409 (unless (type-translateable-p type-spec)
410 (error "Can't translate type ~A" type-spec)))))))))
414 ;;;; Definitons and translations of fundamental types
416 (deftype long (&optional (min '*) (max '*)) `(integer ,min ,max))
417 (deftype unsigned-long (&optional (min '*) (max '*)) `(integer ,min ,max))
418 (deftype int (&optional (min '*) (max '*)) `(long ,min ,max))
419 (deftype unsigned-int (&optional (min '*) (max '*)) `(unsigned-long ,min ,max))
420 (deftype short (&optional (min '*) (max '*)) `(int ,min ,max))
421 (deftype unsigned-short (&optional (min '*) (max '*)) `(unsigned-int ,min ,max))
422 (deftype signed (&optional (size '*)) `(signed-byte ,size))
423 (deftype unsigned (&optional (size '*)) `(signed-byte ,size))
424 (deftype char () 'base-char)
425 (deftype pointer () 'system-area-pointer)
426 (deftype boolean (&optional (size '*))
427 (declare (ignore size))
429 (deftype invalid () nil)
431 (defun atomic-type-p (type-spec)
433 (eq type-spec 'pointer)
434 (not (eq (translate-type-spec type-spec) 'system-area-pointer))))
437 (deftype-method cleanup-alien t (type-spec sap &optional weak-ref)
438 (declare (ignore type-spec sap weak-ref))
442 (deftype-method translate-to-alien integer (type-spec number &optional weak-ref)
443 (declare (ignore type-spec weak-ref))
446 (deftype-method translate-from-alien integer (type-spec number &optional weak-ref)
447 (declare (ignore type-spec weak-ref))
451 (deftype-method translate-type-spec fixnum (type-spec)
452 (declare (ignore type-spec))
453 (translate-type-spec 'signed))
455 (deftype-method size-of fixnum (type-spec)
456 (declare (ignore type-spec))
459 (deftype-method translate-to-alien fixnum (type-spec number &optional weak-ref)
460 (declare (ignore type-spec weak-ref))
463 (deftype-method translate-from-alien fixnum (type-spec number &optional weak-ref)
464 (declare (ignore type-spec weak-ref))
468 (deftype-method translate-type-spec long (type-spec)
469 (declare (ignore type-spec))
470 `(signed ,(* +bits-per-unit+ +size-of-long+)))
472 (deftype-method size-of long (type-spec)
473 (declare (ignore type-spec))
477 (deftype-method translate-type-spec unsigned-long (type-spec)
478 (declare (ignore type-spec))
479 `(unsigned ,(* +bits-per-unit+ +size-of-long+)))
481 (deftype-method size-of unsigned-long (type-spec)
482 (declare (ignore type-spec))
486 (deftype-method translate-type-spec int (type-spec)
487 (declare (ignore type-spec))
488 `(signed ,(* +bits-per-unit+ +size-of-int+)))
490 (deftype-method size-of int (type-spec)
491 (declare (ignore type-spec))
495 (deftype-method translate-type-spec unsigned-int (type-spec)
496 (declare (ignore type-spec))
497 `(unsigned ,(* +bits-per-unit+ +size-of-int+)))
499 (deftype-method size-of unsigned-int (type-spec)
500 (declare (ignore type-spec))
504 (deftype-method translate-type-spec short (type-spec)
505 (declare (ignore type-spec))
506 `(signed ,(* +bits-per-unit+ +size-of-short+)))
508 (deftype-method size-of short (type-spec)
509 (declare (ignore type-spec))
513 (deftype-method translate-type-spec unsigned-short (type-spec)
514 (declare (ignore type-spec))
515 `(unsigned ,(* +bits-per-unit+ +size-of-short+)))
517 (deftype-method size-of unsigned-short (type-spec)
518 (declare (ignore type-spec))
522 (deftype-method translate-type-spec signed-byte (type-spec)
523 (let ((size (second (mklist (type-expand-to 'signed-byte type-spec)))))
526 ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+))
529 (deftype-method size-of signed-byte (type-spec)
530 (let ((size (second (mklist (type-expand-to 'signed-byte type-spec)))))
532 ((member size '(nil *)) +size-of-int+)
533 (t (/ size +bits-per-unit+)))))
535 (deftype-method translate-to-alien signed-byte (type-spec number &optional weak-ref)
536 (declare (ignore type-spec weak-ref))
539 (deftype-method translate-from-alien signed-byte
540 (type-spec number &optional weak-ref)
541 (declare (ignore type-spec weak-ref))
545 (deftype-method translate-type-spec unsigned-byte (type-spec)
546 (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec)))))
549 ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+))
552 (deftype-method size-of unsigned-byte (type-spec)
553 (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec)))))
555 ((member size '(nil *)) +size-of-int+)
556 (t (/ size +bits-per-unit+)))))
558 (deftype-method translate-to-alien unsigned-byte (type-spec number &optional weak-ref)
559 (declare (ignore type-spec weak-ref))
562 (deftype-method translate-from-alien unsigned-byte
563 (type-spec number &optional weak-ref)
564 (declare (ignore type-spec weak-ref))
568 (deftype-method translate-type-spec single-float (type-spec)
569 (declare (ignore type-spec))
572 (deftype-method size-of single-float (type-spec)
573 (declare (ignore type-spec))
576 (deftype-method translate-to-alien single-float (type-spec number &optional weak-ref)
577 (declare (ignore type-spec weak-ref))
580 (deftype-method translate-from-alien single-float
581 (type-spec number &optional weak-ref)
582 (declare (ignore type-spec weak-ref))
586 (deftype-method translate-type-spec double-float (type-spec)
587 (declare (ignore type-spec))
590 (deftype-method size-of double-float (type-spec)
591 (declare (ignore type-spec))
594 (deftype-method translate-to-alien double-float (type-spec number &optional weak-ref)
595 (declare (ignore type-spec weak-ref))
596 `(coerce ,number 'double-float))
598 (deftype-method translate-from-alien double-float
599 (type-spec number &optional weak-ref)
600 (declare (ignore type-spec weak-ref))
604 (deftype-method translate-type-spec base-char (type-spec)
605 (declare (ignore type-spec))
606 `(unsigned ,+bits-per-unit+))
608 (deftype-method size-of base-char (type-spec)
609 (declare (ignore type-spec))
612 (deftype-method translate-to-alien base-char (type-spec char &optional weak-ref)
613 (declare (ignore type-spec weak-ref))
616 (deftype-method translate-from-alien base-char (type-spec code &optional weak-ref)
617 (declare (ignore type-spec weak-ref))
621 (deftype-method translate-type-spec string (type-spec)
622 (declare (ignore type-spec))
623 'system-area-pointer)
625 (deftype-method size-of string (type-spec)
626 (declare (ignore type-spec))
629 (deftype-method translate-to-alien string (type-spec string &optional weak-ref)
630 (declare (ignore type-spec weak-ref))
631 `(let ((string ,string))
632 ;; Always copy strings to prevent seg fault due to GC
634 (make-pointer (1+ (kernel:get-lisp-obj-address string)))
635 (1+ (length string)))))
637 (deftype-method translate-from-alien string
638 (type-spec c-string &optional weak-ref)
639 (declare (ignore type-spec))
640 `(let ((c-string ,c-string))
641 (unless (null-pointer-p c-string)
643 (c-call::%naturalize-c-string c-string)
644 ;,(unless weak-ref `(deallocate-memory c-string))
647 (deftype-method cleanup-alien string (type-spec c-string &optional weak-ref)
649 (unreference-alien type-spec c-string)))
651 (deftype-method unreference-alien string (type-spec c-string)
652 (declare (ignore type-spec))
653 `(let ((c-string ,c-string))
654 (unless (null-pointer-p c-string)
655 (deallocate-memory c-string))))
660 (deftype-method translate-type-spec pathname (type-spec)
661 (declare (ignore type-spec))
662 (translate-type-spec 'string))
664 (deftype-method size-of pathname (type-spec)
665 (declare (ignore type-spec))
668 (deftype-method translate-to-alien pathname (type-spec path &optional weak-ref)
669 (declare (ignore type-spec))
670 (translate-to-alien 'string
671 `(namestring (translate-logical-pathname ,path)) weak-ref))
673 (deftype-method translate-from-alien pathname (type-spec c-string &optional weak-ref)
674 (declare (ignore type-spec))
675 `(parse-namestring ,(translate-from-alien 'string c-string weak-ref)))
677 (deftype-method cleanup-alien pathname (type-spec c-string &optional weak-ref)
678 (declare (ignore type-spec))
679 (cleanup-alien 'string c-string weak-ref))
681 (deftype-method unreference-alien pathname (type-spec c-string)
682 (declare (ignore type-spec))
683 (unreference-alien 'string c-string))
686 (deftype-method translate-type-spec boolean (type-spec)
688 (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
690 (deftype-method size-of boolean (type-spec)
692 (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
694 (deftype-method translate-to-alien boolean (type-spec boolean &optional weak-ref)
695 (declare (ignore type-spec weak-ref))
698 (deftype-method translate-from-alien boolean (type-spec int &optional weak-ref)
699 (declare (ignore type-spec weak-ref))
703 (deftype-method translate-type-spec or (union-type)
704 (let* ((member-types (cdr (type-expand-to 'or union-type)))
705 (alien-type (translate-type-spec (first member-types))))
706 (dolist (type (cdr member-types))
707 (unless (eq alien-type (translate-type-spec type))
708 (error "No common alien type specifier for union type: ~A" union-type)))
711 (deftype-method size-of or (union-type)
712 (size-of (first (cdr (type-expand-to 'or union-type)))))
714 (deftype-method translate-to-alien or (union-type-spec expr &optional weak-ref)
715 (destructuring-bind (name &rest type-specs)
716 (type-expand-to 'or union-type-spec)
717 (declare (ignore name))
718 `(let ((value ,expr))
722 #'(lambda (type-spec)
723 (list type-spec (translate-to-alien type-spec 'value weak-ref)))
727 (deftype-method translate-type-spec system-area-pointer (type-spec)
728 (declare (ignore type-spec))
729 'system-area-pointer)
731 (deftype-method size-of system-area-pointer (type-spec)
732 (declare (ignore type-spec))
735 (deftype-method translate-to-alien system-area-pointer (type-spec sap &optional weak-ref)
736 (declare (ignore type-spec weak-ref))
739 (deftype-method translate-from-alien system-area-pointer
740 (type-spec sap &optional weak-ref)
741 (declare (ignore type-spec weak-ref))
745 (deftype-method translate-type-spec null (type-spec)
746 (declare (ignore type-spec))
747 'system-area-pointer)
749 (deftype-method translate-to-alien null (type-spec expr &optional weak-ref)
750 (declare (ignore type-spec expr weak-ref))
754 (deftype-method translate-type-spec nil (type-spec)
755 (declare (ignore type-spec))
758 (deftype-method translate-from-alien nil (type-spec expr &optional weak-ref)
759 (declare (ignore type-spec weak-ref))