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.6 2001/04/29 20:05:22 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)
57 (dolist (super (cdr (pcl::class-precedence-list class)))
58 (return-if (find-type-method super fname)))))
59 (find-expanded-type-method (type-spec)
60 (multiple-value-bind (expanded-type-spec expanded-p)
61 (type-expand-1 type-spec)
64 (find-applicable-type-method expanded-type-spec fname nil))
66 (find-applicable-type-method t fname nil))))))
72 (find-type-method type-spec fname)
73 (find-superclass-method type-spec)))
76 (find-type-method type-spec fname)
77 (find-expanded-type-method type-spec)
78 (find-superclass-method (find-class type-spec nil))))
81 (find-type-method (first type-spec) fname)
82 (find-expanded-type-method type-spec)))
84 (error "Invalid type specifier ~A" type-spec)))
88 "No applicable method for ~A when called with type specifier ~A"
91 (defmacro deftype-method (fname type lambda-list &body body)
93 (ensure-type-method-fun ',fname)
94 (add-type-method ',type ',fname #'(lambda ,lambda-list ,@body))
97 ;; To make the compiler happy
98 (eval-when (:compile-toplevel :load-toplevel :execute)
99 (define-type-method-fun translate-type-spec (type-spec))
100 (define-type-method-fun size-of (type-spec))
101 (define-type-method-fun translate-to-alien (type-spec expr &optional weak-ref))
102 (define-type-method-fun translate-from-alien (type-spec expr &optional weak-ref))
103 (define-type-method-fun cleanup-alien (type-spec sap &otional weak-ref))
104 (define-type-method-fun unreference-alien (type-spec sap)))
109 (defvar *type-function-cache* (make-hash-table :test #'equal))
111 (defun get-cached-function (type-spec fname)
112 (cdr (assoc fname (gethash type-spec *type-function-cache*))))
114 (defun set-cached-function (type-spec fname function)
115 (push (cons fname function) (gethash type-spec *type-function-cache*))
119 (defun intern-argument-translator (type-spec)
121 (get-cached-function type-spec 'argument-translator)
122 (set-cached-function type-spec 'argument-translator
126 (declare (ignorable object))
127 ,(translate-to-alien type-spec 'object t))))))
129 (defun intern-return-value-translator (type-spec)
131 (get-cached-function type-spec 'return-value-translator)
132 (set-cached-function type-spec 'return-value-translator
136 (declare (ignorable alien))
137 ,(translate-from-alien type-spec 'alien nil))))))
139 (defun intern-cleanup-function (type-spec)
141 (get-cached-function type-spec 'cleanup-function)
142 (set-cached-function type-spec 'cleanup-function
146 (declare (ignorable alien))
147 ,(cleanup-alien type-spec 'alien t))))))
151 ;; Returns a function to write an object of the specified type
152 ;; to a memory location
153 (defun intern-writer-function (type-spec)
155 (get-cached-function type-spec 'writer-function)
156 (set-cached-function type-spec 'writer-function
159 `(lambda (value sap offset)
160 (declare (ignorable value sap offset))
162 (,(sap-ref-fname type-spec) sap offset)
163 ,(translate-to-alien type-spec 'value nil)))))))
165 ;; Returns a function to read an object of the specified type
166 ;; from a memory location
167 (defun intern-reader-function (type-spec)
169 (get-cached-function type-spec 'reader-function)
170 (set-cached-function type-spec 'reader-function
173 `(lambda (sap offset)
174 (declare (ignorable sap offset))
175 ,(translate-from-alien
176 type-spec `(,(sap-ref-fname type-spec) sap offset) t))))))
178 (defun intern-destroy-function (type-spec)
179 (if (atomic-type-p type-spec)
180 #'(lambda (sap offset)
181 (declare (ignore sap offset)))
183 (get-cached-function type-spec 'destroy-function)
184 (set-cached-function type-spec 'destroy-function
187 `(lambda (sap offset)
188 (declare (ignorable sap offset))
190 type-spec `(,(sap-ref-fname type-spec) sap offset))))))))
196 (defconstant +bits-per-unit+ 8
197 "Number of bits in an addressable unit (byte)")
199 ;; Sizes of fundamental C types in addressable units
200 (defconstant +size-of-short+ 2)
201 (defconstant +size-of-int+ 4)
202 (defconstant +size-of-long+ 4)
203 (defconstant +size-of-sap+ 4)
204 (defconstant +size-of-float+ 4)
205 (defconstant +size-of-double+ 8)
207 (defun sap-ref-unsigned (sap offset)
208 (sap-ref-32 sap offset))
210 (defun sap-ref-signed (sap offset)
211 (signed-sap-ref-32 sap offset))
213 (defun sap-ref-fname (type-spec)
214 (let ((alien-type-spec (mklist (translate-type-spec type-spec))))
215 (ecase (first alien-type-spec)
217 (ecase (second alien-type-spec)
223 (ecase (second alien-type-spec)
224 (8 'signed-sap-ref-8)
225 (16 'signed-sap-ref-16)
226 (32 'signed-sap-ref-32)
227 (64 'signed-sap-ref-64)))
228 (system-area-pointer 'sap-ref-sap)
229 (single-float 'sap-ref-single)
230 (double-float 'sap-ref-double))))
233 ;;;; Foreign function call interface
235 (defvar *package-prefix* nil)
237 (defun set-package-prefix (prefix &optional (package *package*))
238 (let ((package (find-package package)))
239 (delete-if #'(lambda (assoc) (eq (car assoc) package)) *package-prefix*)
240 (push (cons package prefix) *package-prefix*))
243 (defun package-prefix (&optional (package *package*))
244 (let ((package (find-package package)))
246 (cdr (assoc package *package-prefix*))
247 (substitute #\_ #\- (string-downcase (package-name package))))))
249 (defun find-prefix-package (prefix)
251 (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=))
252 (find-package (string-upcase prefix))))
254 (defmacro use-prefix (prefix &optional (package *package*))
255 `(eval-when (:compile-toplevel :load-toplevel :execute)
256 (set-package-prefix ,prefix ,package)))
259 (defun default-alien-fname (lisp-name)
260 (let* ((lisp-name-string
261 (if (char= (char (the simple-string (string lisp-name)) 0) #\%)
262 (subseq (the simple-string (string lisp-name)) 1)
264 (prefix (package-prefix *package*))
265 (name (substitute #\_ #\- (string-downcase lisp-name-string))))
266 (if (or (not prefix) (string= prefix ""))
268 (format nil "~A_~A" prefix name))))
270 (defun default-alien-type-name (type-name)
271 (let ((prefix (package-prefix *package*)))
277 (cons prefix (split-string (symbol-name type-name) #\-))))))
279 (defun default-type-name (alien-name)
283 (split-string-if alien-name #'upper-case-p))))
286 (rest parts) #\-) (find-prefix-package (first parts)))))
289 (defmacro defbinding (name lambda-list return-type-spec &rest docs/args)
290 (multiple-value-bind (c-name lisp-name)
292 (values (default-alien-fname name) name)
294 (let ((supplied-lambda-list lambda-list)
297 (dolist (doc/arg docs/args)
298 (if (stringp doc/arg)
301 (destructuring-bind (expr type &optional (style :in)) doc/arg
302 (unless (member style '(:in :out :in-out))
303 (error "Bogus argument style ~S in ~S." style doc/arg))
305 (not supplied-lambda-list)
306 (namep expr) (member style '(:in :in-out)))
307 (push expr lambda-list))
309 (list (if (namep expr) expr (gensym)) expr type style) args)))))
312 c-name lisp-name (or supplied-lambda-list (nreverse lambda-list))
313 return-type-spec (reverse docs) (reverse args)))))
315 ;; For backward compatibility
316 (defmacro define-foreign (&rest args)
317 `(defbinding ,@args))
321 (defun %defbinding (foreign-name lisp-name lambda-list
322 return-type-spec docs args)
323 (ext:collect ((alien-types) (alien-bindings) (alien-parameters)
324 (alien-values) (alien-deallocators))
326 (destructuring-bind (var expr type-spec style) arg
327 (let ((declaration (translate-type-spec type-spec))
328 (deallocation (cleanup-alien type-spec expr t)))
330 ((member style '(:out :in-out))
331 (alien-types `(* ,declaration))
332 (alien-parameters `(addr ,var))
335 ,@(when (eq style :in-out)
336 (list (translate-to-alien type-spec expr t)))))
337 (alien-values (translate-from-alien type-spec var nil)))
339 (alien-types declaration)
341 `(,var ,declaration ,(translate-to-alien type-spec expr t)))
342 (alien-parameters var)
343 (alien-deallocators deallocation))
345 (alien-types declaration)
346 (alien-parameters (translate-to-alien type-spec expr t)))))))
348 (let ((alien-funcall `(alien-funcall ,lisp-name ,@(alien-parameters))))
349 `(defun ,lisp-name ,lambda-list
351 (with-alien ((,lisp-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)))))))))
370 ;;;; Definitons and translations of fundamental types
372 (deftype long (&optional (min '*) (max '*)) `(integer ,min ,max))
373 (deftype unsigned-long (&optional (min '*) (max '*)) `(integer ,min ,max))
374 (deftype int (&optional (min '*) (max '*)) `(long ,min ,max))
375 (deftype unsigned-int (&optional (min '*) (max '*)) `(unsigned-long ,min ,max))
376 (deftype short (&optional (min '*) (max '*)) `(int ,min ,max))
377 (deftype unsigned-short (&optional (min '*) (max '*)) `(unsigned-int ,min ,max))
378 (deftype signed (&optional (size '*)) `(signed-byte ,size))
379 (deftype unsigned (&optional (size '*)) `(signed-byte ,size))
380 (deftype char () 'base-char)
381 (deftype pointer () 'system-area-pointer)
382 (deftype boolean (&optional (size '*))
383 (declare (ignore size))
385 (deftype static (type) type)
386 (deftype invalid () nil)
388 (defun atomic-type-p (type-spec)
390 (eq type-spec 'pointer)
391 (not (eq (translate-type-spec type-spec) 'system-area-pointer))))
394 (deftype-method cleanup-alien t (type-spec sap &optional weak-ref)
395 (declare (ignore type-spec sap weak-ref))
399 (deftype-method translate-to-alien integer (type-spec number &optional weak-ref)
400 (declare (ignore type-spec weak-ref))
403 (deftype-method translate-from-alien integer (type-spec number &optional weak-ref)
404 (declare (ignore type-spec weak-ref))
408 (deftype-method translate-type-spec fixnum (type-spec)
409 (declare (ignore type-spec))
410 (translate-type-spec 'signed))
412 (deftype-method size-of fixnum (type-spec)
413 (declare (ignore type-spec))
416 (deftype-method translate-to-alien fixnum (type-spec number &optional weak-ref)
417 (declare (ignore type-spec weak-ref))
420 (deftype-method translate-from-alien fixnum (type-spec number &optional weak-ref)
421 (declare (ignore type-spec weak-ref))
425 (deftype-method translate-type-spec long (type-spec)
426 (declare (ignore type-spec))
427 `(signed ,(* +bits-per-unit+ +size-of-long+)))
429 (deftype-method size-of long (type-spec)
430 (declare (ignore type-spec))
434 (deftype-method translate-type-spec unsigned-long (type-spec)
435 (declare (ignore type-spec))
436 `(unsigned ,(* +bits-per-unit+ +size-of-long+)))
438 (deftype-method size-of unsigned-long (type-spec)
439 (declare (ignore type-spec))
443 (deftype-method translate-type-spec int (type-spec)
444 (declare (ignore type-spec))
445 `(signed ,(* +bits-per-unit+ +size-of-int+)))
447 (deftype-method size-of int (type-spec)
448 (declare (ignore type-spec))
452 (deftype-method translate-type-spec unsigned-int (type-spec)
453 (declare (ignore type-spec))
454 `(unsigned ,(* +bits-per-unit+ +size-of-int+)))
456 (deftype-method size-of unsigned-int (type-spec)
457 (declare (ignore type-spec))
461 (deftype-method translate-type-spec short (type-spec)
462 (declare (ignore type-spec))
463 `(signed ,(* +bits-per-unit+ +size-of-short+)))
465 (deftype-method size-of short (type-spec)
466 (declare (ignore type-spec))
470 (deftype-method translate-type-spec unsigned-short (type-spec)
471 (declare (ignore type-spec))
472 `(unsigned ,(* +bits-per-unit+ +size-of-short+)))
474 (deftype-method size-of unsigned-short (type-spec)
475 (declare (ignore type-spec))
479 (deftype-method translate-type-spec signed-byte (type-spec)
480 (let ((size (second (mklist (type-expand-to 'signed-byte type-spec)))))
483 ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+))
486 (deftype-method size-of signed-byte (type-spec)
487 (let ((size (second (mklist (type-expand-to 'signed-byte type-spec)))))
489 ((member size '(nil *)) +size-of-int+)
490 (t (/ size +bits-per-unit+)))))
492 (deftype-method translate-to-alien signed-byte (type-spec number &optional weak-ref)
493 (declare (ignore type-spec weak-ref))
496 (deftype-method translate-from-alien signed-byte
497 (type-spec number &optional weak-ref)
498 (declare (ignore type-spec weak-ref))
502 (deftype-method translate-type-spec unsigned-byte (type-spec)
503 (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec)))))
506 ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+))
509 (deftype-method size-of unsigned-byte (type-spec)
510 (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec)))))
512 ((member size '(nil *)) +size-of-int+)
513 (t (/ size +bits-per-unit+)))))
515 (deftype-method translate-to-alien unsigned-byte (type-spec number &optional weak-ref)
516 (declare (ignore type-spec weak-ref))
519 (deftype-method translate-from-alien unsigned-byte
520 (type-spec number &optional weak-ref)
521 (declare (ignore type-spec weak-ref))
525 (deftype-method translate-type-spec single-float (type-spec)
526 (declare (ignore type-spec))
529 (deftype-method size-of single-float (type-spec)
530 (declare (ignore type-spec))
533 (deftype-method translate-to-alien single-float (type-spec number &optional weak-ref)
534 (declare (ignore type-spec weak-ref))
537 (deftype-method translate-from-alien single-float
538 (type-spec number &optional weak-ref)
539 (declare (ignore type-spec weak-ref))
543 (deftype-method translate-type-spec double-float (type-spec)
544 (declare (ignore type-spec))
547 (deftype-method size-of double-float (type-spec)
548 (declare (ignore type-spec))
551 (deftype-method translate-to-alien double-float (type-spec number &optional weak-ref)
552 (declare (ignore type-spec weak-ref))
555 (deftype-method translate-from-alien double-float
556 (type-spec number &optional weak-ref)
557 (declare (ignore type-spec weak-ref))
561 (deftype-method translate-type-spec base-char (type-spec)
562 (declare (ignore type-spec))
563 `(unsigned ,+bits-per-unit+))
565 (deftype-method size-of base-char (type-spec)
566 (declare (ignore type-spec))
569 (deftype-method translate-to-alien base-char (type-spec char &optional weak-ref)
570 (declare (ignore type-spec weak-ref))
573 (deftype-method translate-from-alien base-char (type-spec code &optional weak-ref)
574 (declare (ignore type-spec weak-ref))
578 (deftype-method translate-type-spec string (type-spec)
579 (declare (ignore type-spec))
580 'system-area-pointer)
582 (deftype-method size-of string (type-spec)
583 (declare (ignore type-spec))
586 (deftype-method translate-to-alien string (type-spec string &optional weak-ref)
587 (declare (ignore type-spec weak-ref))
588 `(let ((string ,string))
589 ;; Always copy strings to prevent seg fault due to GC
591 (make-pointer (1+ (kernel:get-lisp-obj-address string)))
592 (1+ (length string)))))
594 (deftype-method translate-from-alien string
595 (type-spec c-string &optional weak-ref)
596 (declare (ignore type-spec))
597 `(let ((c-string ,c-string))
598 (unless (null-pointer-p c-string)
600 (c-call::%naturalize-c-string c-string)
601 ;,(unless weak-ref `(deallocate-memory c-string))
604 (deftype-method cleanup-alien string (type-spec c-string &optional weak-ref)
605 (declare (ignore type-spec))
607 (unreference-alien type-spec c-string)))
609 (deftype-method unreference-alien string (type-spec c-string)
610 `(let ((c-string ,c-string))
611 (unless (null-pointer-p c-string)
612 (deallocate-memory c-string))))
615 (deftype-method translate-type-spec boolean (type-spec)
617 (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
619 (deftype-method size-of boolean (type-spec)
621 (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
623 (deftype-method translate-to-alien boolean (type-spec boolean &optional weak-ref)
624 (declare (ignore type-spec weak-ref))
627 (deftype-method translate-from-alien boolean (type-spec int &optional weak-ref)
628 (declare (ignore type-spec weak-ref))
632 (deftype-method translate-type-spec or (union-type)
633 (let* ((member-types (cdr (type-expand-to 'or union-type)))
634 (alien-type (translate-type-spec (first member-types))))
635 (dolist (type (cdr member-types))
636 (unless (eq alien-type (translate-type-spec type))
637 (error "No common alien type specifier for union type: ~A" union-type)))
640 (deftype-method size-of or (union-type)
641 (size-of (first (cdr (type-expand-to 'or union-type)))))
643 (deftype-method translate-to-alien or (union-type-spec expr &optional weak-ref)
644 (destructuring-bind (name &rest type-specs)
645 (type-expand-to 'or union-type-spec)
646 (declare (ignore name))
647 `(let ((value ,expr))
651 #'(lambda (type-spec)
652 (list type-spec (translate-to-alien type-spec 'value weak-ref)))
656 (deftype-method translate-type-spec system-area-pointer (type-spec)
657 (declare (ignore type-spec))
658 'system-area-pointer)
660 (deftype-method size-of system-area-pointer (type-spec)
661 (declare (ignore type-spec))
664 (deftype-method translate-to-alien system-area-pointer (type-spec sap &optional weak-ref)
665 (declare (ignore type-spec weak-ref))
668 (deftype-method translate-from-alien system-area-pointer
669 (type-spec sap &optional weak-ref)
670 (declare (ignore type-spec weak-ref))
674 (deftype-method translate-type-spec null (type-spec)
675 (declare (ignore type-spec))
676 'system-area-pointer)
678 (deftype-method translate-to-alien null (type-spec expr &optional weak-ref)
679 (declare (ignore type-spec expr weak-ref))
683 (deftype-method translate-type-spec nil (type-spec)
684 (declare (ignore type-spec))