-;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
+;; Common Lisp bindings for GTK+ v2.x
+;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2 of the License, or (at your option) any later version.
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: ffi.lisp,v 1.4 2004-11-09 10:04:35 espen Exp $
+;; $Id: ffi.lisp,v 1.20 2005-04-23 16:48:50 espen Exp $
(in-package "GLIB")
(defun default-alien-fname (lisp-name)
- (let* ((lisp-name-string
- (if (char= (char (the simple-string (string lisp-name)) 0) #\%)
- (subseq (the simple-string (string lisp-name)) 1)
- (string lisp-name)))
- (prefix (package-prefix *package*))
- (name (substitute #\_ #\- (string-downcase lisp-name-string))))
+ (let* ((name (substitute #\_ #\- (string-downcase lisp-name)))
+ (stripped-name
+ (cond
+ ((and
+ (char= (char name 0) #\%)
+ (string= "_p" name :start2 (- (length name) 2)))
+ (subseq name 1 (- (length name) 2)))
+ ((char= (char name 0) #\%)
+ (subseq name 1))
+ ((string= "_p" name :start2 (- (length name) 2))
+ (subseq name 0 (- (length name) 2)))
+ (name)))
+ (prefix (package-prefix *package*)))
(if (or (not prefix) (string= prefix ""))
- name
- (format nil "~A_~A" prefix name))))
+ stripped-name
+ (format nil "~A_~A" prefix stripped-name))))
(defun default-alien-type-name (type-name)
(let ((prefix (package-prefix *package*)))
(not supplied-lambda-list)
(namep expr) (member style '(:in :in-out :return)))
(push expr lambda-list))
- (push
- (list (if (namep expr)
- (make-symbol (string expr))
- (gensym))
- expr (mklist type) style) args)))))
+ (push (list (cond
+ ((and (namep expr) (eq style :out)) expr)
+ ((namep expr) (make-symbol (string expr)))
+ ((gensym)))
+ expr (mklist type) style) args)))))
(%defbinding
c-name lisp-name (or supplied-lambda-list (nreverse lambda-list))
return-type (reverse docs) (reverse args)))))
-#+cmu
+#+(or cmu sbcl)
(defun %defbinding (foreign-name lisp-name lambda-list return-type docs args)
- (ext:collect ((alien-types) (alien-bindings) (alien-parameters)
- (return-values) (cleanup-forms))
+ (collect ((alien-types) (alien-bindings) (alien-parameters)
+ (return-values) (cleanup-forms))
(dolist (arg args)
(destructuring-bind (var expr type style) arg
(let ((declaration (alien-type type))
(alien-parameters `(addr ,var))
(alien-bindings
`(,var ,declaration
- ,@(when (eq style :in-out)
- (list (to-alien-form expr type)))))
+ ,@(cond
+ ((eq style :in-out) (list (to-alien-form expr type)))
+ ((eq declaration 'system-area-pointer)
+ (list '(make-pointer 0))))))
(return-values (from-alien-form var type)))
((eq style :return)
(alien-types declaration)
(alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters))))
`(defun ,lisp-name ,lambda-list
,@docs
- (declare (optimize (ext:inhibit-warnings 3)))
+ #+cmu(declare (optimize (inhibit-warnings 3)))
+ #+sbcl(declare (muffle-conditions compiler-note))
(with-alien ((,alien-name
(function
,(alien-type return-type)
;;; Creates bindings at runtime
(defun mkbinding (name return-type &rest arg-types)
- (declare (optimize (ext:inhibit-warnings 3)))
+ #+cmu(declare (optimize (inhibit-warnings 3)))
+ #+sbcl(declare (muffle-conditions compiler-note))
(let* ((ftype
`(function ,@(mapcar #'alien-type (cons return-type arg-types))))
(alien
- (alien::%heap-alien
- (alien::make-heap-alien-info
- :type (alien::parse-alien-type ftype)
- :sap-form (system:foreign-symbol-address name :flavor :code))))
+ (%heap-alien
+ (make-heap-alien-info
+ :type (parse-alien-type ftype #+sbcl nil)
+ :sap-form (foreign-symbol-address name))))
(translate-arguments (mapcar #'to-alien-function arg-types))
(translate-return-value (from-alien-function return-type))
(cleanup-arguments (mapcar #'cleanup-function arg-types)))
(map-into args #'funcall translate-arguments args)
(prog1
(funcall translate-return-value
- (apply #'alien:alien-funcall alien args))
+ (apply #'alien-funcall alien args))
(mapc #'funcall cleanup-arguments args)))))
(defmacro defcallback (name (return-type &rest args) &body body)
- `(def-callback ,name
- (,(alien-type return-type)
- ,@(mapcar #'(lambda (arg)
- (destructuring-bind (name type) arg
- `(,name ,(alien-type type))))
- args))
- ,(to-alien-form
- `(let (,@(mapcar #'(lambda (arg)
- (destructuring-bind (name type) arg
- `(,name ,(from-alien-form name type))))
- args))
- ,@body)
- return-type)))
-
-
+ (let ((def-callback #+cmu'alien:def-callback
+ #+sbcl'sb-alien:define-alien-function))
+ `(,def-callback ,name
+ (,(alien-type return-type)
+ ,@(mapcar #'(lambda (arg)
+ (destructuring-bind (name type) arg
+ `(,name ,(alien-type type))))
+ args))
+ ,(to-alien-form
+ `(let (,@(delete nil
+ (mapcar #'(lambda (arg)
+ (destructuring-bind (name type) arg
+ (let ((from-alien
+ (from-alien-form name type)))
+ (unless (eq name from-alien)
+ `(,name ,from-alien)))))
+ args)))
+ ,@body)
+ return-type))))
+
+#+sbcl
+(defun callback (af)
+ (sb-alien:alien-function-sap af))
+
+#+sbcl
+(deftype callback () 'sb-alien:alien-function)
;;;; Definitons and translations of fundamental types
(def-type-method from-alien-function ())
(def-type-method cleanup-function ())
+(def-type-method copy-to-alien-form (form))
+(def-type-method copy-to-alien-function ())
+(def-type-method copy-from-alien-form (form))
+(def-type-method copy-from-alien-function ())
+
(def-type-method writer-function ())
(def-type-method reader-function ())
(def-type-method destroy-function ())
+(def-type-method unbound-value ()
+ "First return value is true if the type has an unbound value, second return value is the actual unbound value")
+
;; Sizes of fundamental C types in bytes (8 bits)
(defconstant +size-of-short+ 2)
(defmethod destroy-function ((type t) &rest args)
(declare (ignore type args))
- #'(lambda (location offset)
+ #'(lambda (location &optional offset)
(declare (ignore location offset))))
+(defmethod copy-to-alien-form (form (type t) &rest args)
+ (apply #'to-alien-form form type args))
+
+(defmethod copy-to-alien-function ((type t) &rest args)
+ (apply #'to-alien-function type args))
+
+(defmethod copy-from-alien-form (form (type t) &rest args)
+ (apply #'from-alien-form form type args))
+
+(defmethod copy-from-alien-function ((type t) &rest args)
+ (apply #'from-alien-function type args))
+
(defmethod alien-type ((type (eql 'signed-byte)) &rest args)
(declare (ignore type))
(destructuring-bind (&optional (size '*)) args
(ecase size
- (#.+bits-of-byte+ '(signed-byte 8))
- (#.+bits-of-short+ 'c-call:short)
- ((* #.+bits-of-int+) 'c-call:int)
- (#.+bits-of-long+ 'c-call:long))))
+ (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8))
+ (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short)
+ ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int)
+ (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long))))
(defmethod size-of ((type (eql 'signed-byte)) &rest args)
(declare (ignore type))
((* #.+bits-of-int+) +size-of-int+)
(#.+bits-of-long+ +size-of-long+))))
+(defmethod unbound-value ((type t) &rest args)
+ (declare (ignore type args))
+ nil)
+
(defmethod writer-function ((type (eql 'signed-byte)) &rest args)
(declare (ignore type))
(destructuring-bind (&optional (size '*)) args
(defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)
(destructuring-bind (&optional (size '*)) args
(ecase size
- (#.+bits-of-byte+ '(unsigned-byte 8))
- (#.+bits-of-short+ 'c-call:unsigned-short)
- ((* #.+bits-of-int+) 'c-call:unsigned-int)
- (#.+bits-of-long+ 'c-call:unsigned-long))))
+ (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8))
+ (#.+bits-of-short+ #+cmu 'c-call:unsigned-short
+ #+sbcl 'sb-alien:unsigned-short)
+ ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int
+ #+sbcl 'sb-alien:unsigned-int)
+ (#.+bits-of-long+ #+cmu 'c-call:unsigned-long
+ #+sbcl 'sb-alien:unsigned-long))))
(defmethod size-of ((type (eql 'unsigned-byte)) &rest args)
(apply #'size-of 'signed args))
(declare (ignore type args))
(size-of 'signed-byte))
+(defmethod writer-function ((type (eql 'integer)) &rest args)
+ (declare (ignore type args))
+ (writer-function 'signed-byte))
+
+(defmethod reader-function ((type (eql 'integer)) &rest args)
+ (declare (ignore type args))
+ (reader-function 'signed-byte))
+
(defmethod alien-type ((type (eql 'fixnum)) &rest args)
(declare (ignore type args))
(defmethod alien-type ((type (eql 'single-float)) &rest args)
(declare (ignore type args))
- 'alien:single-float)
+ #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float)
(defmethod size-of ((type (eql 'single-float)) &rest args)
(declare (ignore type args))
+size-of-float+)
+(defmethod to-alien-form (form (type (eql 'single-float)) &rest args)
+ (declare (ignore type args))
+ `(coerce ,form 'single-float))
+
+(defmethod to-alien-function ((type (eql 'single-float)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (number)
+ (coerce number 'single-float)))
+
(defmethod writer-function ((type (eql 'single-float)) &rest args)
(declare (ignore type args))
#'(lambda (value location &optional (offset 0))
(defmethod alien-type ((type (eql 'double-float)) &rest args)
(declare (ignore type args))
- 'alien:double-float)
+ #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float)
(defmethod size-of ((type (eql 'double-float)) &rest args)
(declare (ignore type args))
- +size-of-float+)
+ +size-of-double+)
+
+(defmethod to-alien-form (form (type (eql 'double-float)) &rest args)
+ (declare (ignore type args))
+ `(coerce ,form 'double-float))
+
+(defmethod to-alien-function ((type (eql 'double-float)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (number)
+ (coerce number 'double-float)))
(defmethod writer-function ((type (eql 'double-float)) &rest args)
(declare (ignore type args))
(defmethod alien-type ((type (eql 'base-char)) &rest args)
(declare (ignore type args))
- 'c-call:char)
+ #+cmu 'c-call:char #+sbcl 'sb-alien:char)
(defmethod size-of ((type (eql 'base-char)) &rest args)
(declare (ignore type args))
(declare (ignore type args))
`(let ((string ,string))
;; Always copy strings to prevent seg fault due to GC
+ #+cmu
(copy-memory
- (make-pointer (1+ (kernel:get-lisp-obj-address string)))
- (1+ (length string)))))
+ (vector-sap (coerce string 'simple-base-string))
+ (1+ (length string)))
+ #+sbcl
+ (let ((utf8 (%deport-utf8-string string)))
+ (copy-memory (vector-sap utf8) (length utf8)))))
(defmethod to-alien-function ((type (eql 'string)) &rest args)
(declare (ignore type args))
#'(lambda (string)
+ #+cmu
(copy-memory
- (make-pointer (1+ (kernel:get-lisp-obj-address string)))
- (1+ (length string)))))
+ (vector-sap (coerce string 'simple-base-string))
+ (1+ (length string)))
+ #+sbcl
+ (let ((utf8 (%deport-utf8-string string)))
+ (copy-memory (vector-sap utf8) (length utf8)))))
(defmethod from-alien-form (string (type (eql 'string)) &rest args)
(declare (ignore type args))
`(let ((string ,string))
(unless (null-pointer-p string)
- (c-call::%naturalize-c-string string))))
+ (prog1
+ #+cmu(%naturalize-c-string string)
+ #+sbcl(%naturalize-utf8-string string)
+ (deallocate-memory string)))))
(defmethod from-alien-function ((type (eql 'string)) &rest args)
(declare (ignore type args))
#'(lambda (string)
(unless (null-pointer-p string)
- (c-call::%naturalize-c-string string))))
+ (prog1
+ #+cmu(%naturalize-c-string string)
+ #+sbcl(%naturalize-utf8-string string)
+ (deallocate-memory string)))))
(defmethod cleanup-form (string (type (eql 'string)) &rest args)
(declare (ignore type args))
(unless (null-pointer-p string)
(deallocate-memory string))))
+(defmethod copy-from-alien-form (string (type (eql 'string)) &rest args)
+ (declare (ignore type args))
+ `(let ((string ,string))
+ (unless (null-pointer-p string)
+ #+cmu(%naturalize-c-string string)
+ #+sbcl(%naturalize-utf8-string string))))
+
+(defmethod copy-from-alien-function ((type (eql 'string)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (string)
+ (unless (null-pointer-p string)
+ #+cmu(%naturalize-c-string string)
+ #+sbcl(%naturalize-utf8-string string))))
+
(defmethod writer-function ((type (eql 'string)) &rest args)
(declare (ignore type args))
#'(lambda (string location &optional (offset 0))
(assert (null-pointer-p (sap-ref-sap location offset)))
(setf (sap-ref-sap location offset)
+ #+cmu
(copy-memory
- (make-pointer (1+ (kernel:get-lisp-obj-address string)))
- (1+ (length string))))))
+ (vector-sap (coerce string 'simple-base-string))
+ (1+ (length string)))
+ #+sbcl
+ (let ((utf8 (%deport-utf8-string string)))
+ (copy-memory (vector-sap utf8) (length utf8))))))
(defmethod reader-function ((type (eql 'string)) &rest args)
(declare (ignore type args))
#'(lambda (location &optional (offset 0))
(unless (null-pointer-p (sap-ref-sap location offset))
- (c-call::%naturalize-c-string (sap-ref-sap location offset)))))
+ #+cmu(%naturalize-c-string (sap-ref-sap location offset))
+ #+sbcl(%naturalize-utf8-string (sap-ref-sap location offset)))))
(defmethod destroy-function ((type (eql 'string)) &rest args)
(declare (ignore type args))
(deallocate-memory (sap-ref-sap location offset))
(setf (sap-ref-sap location offset) (make-pointer 0)))))
+(defmethod unbound-value ((type (eql 'string)) &rest args)
+ (declare (ignore type args))
+ (values t nil))
+
(defmethod alien-type ((type (eql 'pathname)) &rest args)
(declare (ignore type args))
(declare (ignore type args))
(destroy-function 'string))
+(defmethod unbound-value ((type (eql 'pathname)) &rest args)
+ (declare (ignore type args))
+ (unbound-value 'string))
+
(defmethod alien-type ((type (eql 'boolean)) &rest args)
(apply #'alien-type 'signed-byte args))
(defmethod alien-type ((type (eql 'nil)) &rest args)
(declare (ignore type args))
- 'c-call:void)
+ 'void)
(defmethod from-alien-function ((type (eql 'nil)) &rest args)
(declare (ignore type args))
#'(lambda (value)
(declare (ignore value))
(values)))
+
+
+(defmethod alien-type ((type (eql 'copy-of)) &rest args)
+ (declare (ignore type))
+ (alien-type (first args)))
+
+(defmethod size-of ((type (eql 'copy-of)) &rest args)
+ (declare (ignore type))
+ (size-of (first args)))
+
+(defmethod to-alien-form (form (type (eql 'copy-of)) &rest args)
+ (declare (ignore type))
+ (copy-to-alien-form form (first args)))
+
+(defmethod to-alien-function ((type (eql 'copy-of)) &rest args)
+ (declare (ignore type))
+ (copy-to-alien-function (first args)))
+
+(defmethod from-alien-form (form (type (eql 'copy-of)) &rest args)
+ (declare (ignore type))
+ (copy-from-alien-form form (first args)))
+
+(defmethod from-alien-function ((type (eql 'copy-of)) &rest args)
+ (declare (ignore type))
+ (copy-from-alien-function (first args)))
+
+(defmethod reader-function ((type (eql 'copy-of)) &rest args)
+ (declare (ignore type))
+ (reader-function (first args)))
+
+(defmethod writer-function ((type (eql 'copy-of)) &rest args)
+ (declare (ignore type))
+ (writer-function (first args)))
+
+
+(defmethod alien-type ((type (eql 'callback)) &rest args)
+ (declare (ignore type args))
+ (alien-type 'pointer))
+
+(defmethod size-of ((type (eql 'callback)) &rest args)
+ (declare (ignore type args))
+ (size-of 'pointer))
+
+(defmethod to-alien-form (callback (type (eql 'callback)) &rest args)
+ (declare (ignore type args))
+ #+cmu `(callback ,callback)
+ #+sbcl `(sb-alien:alien-function-sap ,callback))
+
+(defmethod to-alien-function ((type (eql 'callback)) &rest args)
+ (declare (ignore type args))
+ #+cmu #'(lambda (callback) (callback callback))
+ #+sbcl #'sb-alien:alien-function-sap)
+
+#+cmu
+(defun find-callback (pointer)
+ (find pointer alien::*callbacks* :key #'callback-trampoline :test #'sap=))
+
+(defmethod from-alien-form (pointer (type (eql 'callback)) &rest args)
+ (declare (ignore type args))
+ #+cmu `(find-callback ,pointer)
+ #+sbcl `(sb-alien::%find-alien-function ,pointer))
+
+(defmethod from-alien-function ((type (eql 'callback)) &rest args)
+ (declare (ignore type args))
+ #+cmu #'find-callback
+ #+sbcl #'sb-alien::%find-alien-function)
+
+(defmethod writer-function ((type (eql 'callback)) &rest args)
+ (declare (ignore type args))
+ (let ((writer (writer-function 'pointer))
+ (to-alien (to-alien-function 'callback)))
+ #'(lambda (callback location &optional (offset 0))
+ (funcall writer (funcall to-alien callback) location offset))))
+
+(defmethod reader-function ((type (eql 'callback)) &rest args)
+ (declare (ignore type args))
+ (let ((reader (reader-function 'pointer))
+ (from-alien (from-alien-function 'callback)))
+ #'(lambda (location &optional (offset 0))
+ (let ((pointer (funcall reader location offset)))
+ (unless (null-pointer-p pointer)
+ (funcall from-alien pointer))))))
+
+(defmethod unbound-value ((type (eql 'callback)) &rest args)
+ (declare (ignore type args))
+ (values t nil))
~mdw / clg / blobdiff