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: gforeign.lisp,v 1.12 2001-10-21 21:33:57 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) 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-funcall `(alien-funcall ,lisp-name ,@(alien-parameters))))
347 `(defun ,lisp-name ,lambda-list
349 (with-alien ((,lisp-name
351 ,(translate-type-spec return-type-spec)
353 :extern ,foreign-name)
355 ,(if return-type-spec
357 ,(translate-from-alien return-type-spec alien-funcall nil)))
358 ,@(alien-deallocators)
359 (values result ,@(alien-values)))
362 ,@(alien-deallocators)
363 (values ,@(alien-values)))))))))
366 (defun mkbinding (name return-type &rest arg-types)
367 (declare (optimize (ext:inhibit-warnings 3)))
370 ,@(mapcar #'translate-type-spec (cons return-type arg-types))))
373 (alien::make-heap-alien-info
374 :type (alien::parse-alien-type ftype)
375 :sap-form (system:foreign-symbol-address name))))
377 (mapcar #'intern-return-value-translator arg-types))
378 (translate-return-value (intern-return-value-translator return-type))
379 (cleanup-arguments (mapcar #'intern-cleanup-function arg-types)))
381 #'(lambda (&rest args)
382 (map-into args #'funcall translate-arguments args)
385 translate-return-value (apply #'alien:alien-funcall alien args))
386 (mapc #'funcall cleanup-arguments args)))))
389 (defun type-translateable-p (type-spec)
390 (find-applicable-type-method type-spec 'translate-type-spec nil))
392 (defun every-type-translateable-p (type-specs)
393 (every #'type-translateable-p type-specs))
395 (defun mkbinding-late (name return-type &rest arg-types)
396 (if (every-type-translateable-p (cons return-type arg-types))
397 (apply #'mkbinding name return-type arg-types)
399 #'(lambda (&rest args)
401 (binding (apply binding args))
402 ((every-type-translateable-p (cons return-type arg-types))
403 (setq binding (apply #'mkbinding name return-type arg-types))
404 (apply binding args))
406 (dolist (type-spec (cons return-type arg-types))
407 (unless (type-translateable-p type-spec)
408 (error "Can't translate type ~A" type-spec)))))))))
412 ;;;; Definitons and translations of fundamental types
414 (deftype long (&optional (min '*) (max '*)) `(integer ,min ,max))
415 (deftype unsigned-long (&optional (min '*) (max '*)) `(integer ,min ,max))
416 (deftype int (&optional (min '*) (max '*)) `(long ,min ,max))
417 (deftype unsigned-int (&optional (min '*) (max '*)) `(unsigned-long ,min ,max))
418 (deftype short (&optional (min '*) (max '*)) `(int ,min ,max))
419 (deftype unsigned-short (&optional (min '*) (max '*)) `(unsigned-int ,min ,max))
420 (deftype signed (&optional (size '*)) `(signed-byte ,size))
421 (deftype unsigned (&optional (size '*)) `(signed-byte ,size))
422 (deftype char () 'base-char)
423 (deftype pointer () 'system-area-pointer)
424 (deftype boolean (&optional (size '*))
425 (declare (ignore size))
427 (deftype invalid () nil)
429 (defun atomic-type-p (type-spec)
431 (eq type-spec 'pointer)
432 (not (eq (translate-type-spec type-spec) 'system-area-pointer))))
435 (deftype-method cleanup-alien t (type-spec sap &optional weak-ref)
436 (declare (ignore type-spec sap weak-ref))
440 (deftype-method translate-to-alien integer (type-spec number &optional weak-ref)
441 (declare (ignore type-spec weak-ref))
444 (deftype-method translate-from-alien integer (type-spec number &optional weak-ref)
445 (declare (ignore type-spec weak-ref))
449 (deftype-method translate-type-spec fixnum (type-spec)
450 (declare (ignore type-spec))
451 (translate-type-spec 'signed))
453 (deftype-method size-of fixnum (type-spec)
454 (declare (ignore type-spec))
457 (deftype-method translate-to-alien fixnum (type-spec number &optional weak-ref)
458 (declare (ignore type-spec weak-ref))
461 (deftype-method translate-from-alien fixnum (type-spec number &optional weak-ref)
462 (declare (ignore type-spec weak-ref))
466 (deftype-method translate-type-spec long (type-spec)
467 (declare (ignore type-spec))
468 `(signed ,(* +bits-per-unit+ +size-of-long+)))
470 (deftype-method size-of long (type-spec)
471 (declare (ignore type-spec))
475 (deftype-method translate-type-spec unsigned-long (type-spec)
476 (declare (ignore type-spec))
477 `(unsigned ,(* +bits-per-unit+ +size-of-long+)))
479 (deftype-method size-of unsigned-long (type-spec)
480 (declare (ignore type-spec))
484 (deftype-method translate-type-spec int (type-spec)
485 (declare (ignore type-spec))
486 `(signed ,(* +bits-per-unit+ +size-of-int+)))
488 (deftype-method size-of int (type-spec)
489 (declare (ignore type-spec))
493 (deftype-method translate-type-spec unsigned-int (type-spec)
494 (declare (ignore type-spec))
495 `(unsigned ,(* +bits-per-unit+ +size-of-int+)))
497 (deftype-method size-of unsigned-int (type-spec)
498 (declare (ignore type-spec))
502 (deftype-method translate-type-spec short (type-spec)
503 (declare (ignore type-spec))
504 `(signed ,(* +bits-per-unit+ +size-of-short+)))
506 (deftype-method size-of short (type-spec)
507 (declare (ignore type-spec))
511 (deftype-method translate-type-spec unsigned-short (type-spec)
512 (declare (ignore type-spec))
513 `(unsigned ,(* +bits-per-unit+ +size-of-short+)))
515 (deftype-method size-of unsigned-short (type-spec)
516 (declare (ignore type-spec))
520 (deftype-method translate-type-spec signed-byte (type-spec)
521 (let ((size (second (mklist (type-expand-to 'signed-byte type-spec)))))
524 ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+))
527 (deftype-method size-of signed-byte (type-spec)
528 (let ((size (second (mklist (type-expand-to 'signed-byte type-spec)))))
530 ((member size '(nil *)) +size-of-int+)
531 (t (/ size +bits-per-unit+)))))
533 (deftype-method translate-to-alien signed-byte (type-spec number &optional weak-ref)
534 (declare (ignore type-spec weak-ref))
537 (deftype-method translate-from-alien signed-byte
538 (type-spec number &optional weak-ref)
539 (declare (ignore type-spec weak-ref))
543 (deftype-method translate-type-spec unsigned-byte (type-spec)
544 (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec)))))
547 ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+))
550 (deftype-method size-of unsigned-byte (type-spec)
551 (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec)))))
553 ((member size '(nil *)) +size-of-int+)
554 (t (/ size +bits-per-unit+)))))
556 (deftype-method translate-to-alien unsigned-byte (type-spec number &optional weak-ref)
557 (declare (ignore type-spec weak-ref))
560 (deftype-method translate-from-alien unsigned-byte
561 (type-spec number &optional weak-ref)
562 (declare (ignore type-spec weak-ref))
566 (deftype-method translate-type-spec single-float (type-spec)
567 (declare (ignore type-spec))
570 (deftype-method size-of single-float (type-spec)
571 (declare (ignore type-spec))
574 (deftype-method translate-to-alien single-float (type-spec number &optional weak-ref)
575 (declare (ignore type-spec weak-ref))
578 (deftype-method translate-from-alien single-float
579 (type-spec number &optional weak-ref)
580 (declare (ignore type-spec weak-ref))
584 (deftype-method translate-type-spec double-float (type-spec)
585 (declare (ignore type-spec))
588 (deftype-method size-of double-float (type-spec)
589 (declare (ignore type-spec))
592 (deftype-method translate-to-alien double-float (type-spec number &optional weak-ref)
593 (declare (ignore type-spec weak-ref))
596 (deftype-method translate-from-alien double-float
597 (type-spec number &optional weak-ref)
598 (declare (ignore type-spec weak-ref))
602 (deftype-method translate-type-spec base-char (type-spec)
603 (declare (ignore type-spec))
604 `(unsigned ,+bits-per-unit+))
606 (deftype-method size-of base-char (type-spec)
607 (declare (ignore type-spec))
610 (deftype-method translate-to-alien base-char (type-spec char &optional weak-ref)
611 (declare (ignore type-spec weak-ref))
614 (deftype-method translate-from-alien base-char (type-spec code &optional weak-ref)
615 (declare (ignore type-spec weak-ref))
619 (deftype-method translate-type-spec string (type-spec)
620 (declare (ignore type-spec))
621 'system-area-pointer)
623 (deftype-method size-of string (type-spec)
624 (declare (ignore type-spec))
627 (deftype-method translate-to-alien string (type-spec string &optional weak-ref)
628 (declare (ignore type-spec weak-ref))
629 `(let ((string ,string))
630 ;; Always copy strings to prevent seg fault due to GC
632 (make-pointer (1+ (kernel:get-lisp-obj-address string)))
633 (1+ (length string)))))
635 (deftype-method translate-from-alien string
636 (type-spec c-string &optional weak-ref)
637 (declare (ignore type-spec))
638 `(let ((c-string ,c-string))
639 (unless (null-pointer-p c-string)
641 (c-call::%naturalize-c-string c-string)
642 ;,(unless weak-ref `(deallocate-memory c-string))
645 (deftype-method cleanup-alien string (type-spec c-string &optional weak-ref)
647 (unreference-alien type-spec c-string)))
649 (deftype-method unreference-alien string (type-spec c-string)
650 (declare (ignore type-spec))
651 `(let ((c-string ,c-string))
652 (unless (null-pointer-p c-string)
653 (deallocate-memory c-string))))
656 (deftype-method translate-type-spec boolean (type-spec)
658 (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
660 (deftype-method size-of boolean (type-spec)
662 (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
664 (deftype-method translate-to-alien boolean (type-spec boolean &optional weak-ref)
665 (declare (ignore type-spec weak-ref))
668 (deftype-method translate-from-alien boolean (type-spec int &optional weak-ref)
669 (declare (ignore type-spec weak-ref))
673 (deftype-method translate-type-spec or (union-type)
674 (let* ((member-types (cdr (type-expand-to 'or union-type)))
675 (alien-type (translate-type-spec (first member-types))))
676 (dolist (type (cdr member-types))
677 (unless (eq alien-type (translate-type-spec type))
678 (error "No common alien type specifier for union type: ~A" union-type)))
681 (deftype-method size-of or (union-type)
682 (size-of (first (cdr (type-expand-to 'or union-type)))))
684 (deftype-method translate-to-alien or (union-type-spec expr &optional weak-ref)
685 (destructuring-bind (name &rest type-specs)
686 (type-expand-to 'or union-type-spec)
687 (declare (ignore name))
688 `(let ((value ,expr))
692 #'(lambda (type-spec)
693 (list type-spec (translate-to-alien type-spec 'value weak-ref)))
697 (deftype-method translate-type-spec system-area-pointer (type-spec)
698 (declare (ignore type-spec))
699 'system-area-pointer)
701 (deftype-method size-of system-area-pointer (type-spec)
702 (declare (ignore type-spec))
705 (deftype-method translate-to-alien system-area-pointer (type-spec sap &optional weak-ref)
706 (declare (ignore type-spec weak-ref))
709 (deftype-method translate-from-alien system-area-pointer
710 (type-spec sap &optional weak-ref)
711 (declare (ignore type-spec weak-ref))
715 (deftype-method translate-type-spec null (type-spec)
716 (declare (ignore type-spec))
717 'system-area-pointer)
719 (deftype-method translate-to-alien null (type-spec expr &optional weak-ref)
720 (declare (ignore type-spec expr weak-ref))
724 (deftype-method translate-type-spec nil (type-spec)
725 (declare (ignore type-spec))
728 (deftype-method translate-from-alien nil (type-spec expr &optional weak-ref)
729 (declare (ignore type-spec weak-ref))