Changed to use of settable FOREIGN-LOCATION

[clg] / glib / ffi.lisp

diff --git a/glib/ffi.lisp b/glib/ffi.lisp
index 6797b39ed1275c63a23e7d924c04aad32b7ffd39..e024d422e6ced014cf4cfe3ea7def7d66c0a4168 100644 (file)
--- a/glib/ffi.lisp
+++ b/glib/ffi.lisp
@@ -1,21 +1,26 @@
-;; 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.14 2005-02-14 17:49:17 espen Exp $
+;; $Id: ffi.lisp,v 1.23 2006-02-06 18:12:19 espen Exp $

 
 (in-package "GLIB")
 
 
 (in-package "GLIB")
 


@@ -128,9 +133,10 @@ (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args)
             (alien-parameters `(addr ,var))
             (alien-bindings
              `(,var ,declaration
             (alien-parameters `(addr ,var))
             (alien-bindings
              `(,var ,declaration

-               ,(if (eq style :in-out)
-                    (to-alien-form expr type)
-                  (make-pointer 0))))
+               ,@(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)
             (return-values (from-alien-form var type)))
            ((eq style :return)
             (alien-types declaration)


@@ -183,7 +189,10 @@ (defun mkbinding (name return-type &rest arg-types)
          (%heap-alien
           (make-heap-alien-info
            :type (parse-alien-type ftype #+sbcl nil)
          (%heap-alien
           (make-heap-alien-info
            :type (parse-alien-type ftype #+sbcl nil)

-           :sap-form (foreign-symbol-address name))))
+           :sap-form (let ((address (foreign-symbol-address name)))
+                       (etypecase address
+                         (integer (int-sap address))
+                         (system-area-pointer address))))))

         (translate-arguments (mapcar #'to-alien-function arg-types))
         (translate-return-value (from-alien-function return-type))
         (cleanup-arguments (mapcar #'cleanup-function arg-types)))
         (translate-arguments (mapcar #'to-alien-function arg-types))
         (translate-return-value (from-alien-function return-type))
         (cleanup-arguments (mapcar #'cleanup-function arg-types)))


@@ -206,10 +215,14 @@ (defmacro defcallback (name (return-type &rest args) &body body)
                          `(,name ,(alien-type type))))
                    args))
        ,(to-alien-form 
                          `(,name ,(alien-type type))))
                    args))
        ,(to-alien-form 

-        `(let (,@(mapcar #'(lambda (arg)
-                             (destructuring-bind (name type) arg
-                               `(,name ,(from-alien-form name type))))
-                         args))
+        `(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))))
 
            ,@body)
         return-type))))
 


@@ -217,6 +230,8 @@ (defmacro defcallback (name (return-type &rest args) &body body)
 (defun callback (af)
   (sb-alien:alien-function-sap af))
 
 (defun callback (af)
   (sb-alien:alien-function-sap af))
 

+#+sbcl
+(deftype callback () 'sb-alien:alien-function)

 
 ;;;; Definitons and translations of fundamental types
 
 
 ;;;; Definitons and translations of fundamental types
 


@@ -332,7 +347,6 @@ (defmethod copy-from-alien-form  (form (type t) &rest args)
 (defmethod copy-from-alien-function  ((type t) &rest args)
   (apply #'from-alien-function 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
 (defmethod alien-type ((type (eql 'signed-byte)) &rest args)
   (declare (ignore type))
   (destructuring-bind (&optional (size '*)) args


@@ -374,13 +388,17 @@ (defmethod reader-function ((type (eql 'signed-byte)) &rest args)
   (destructuring-bind (&optional (size '*)) args
     (let ((size (if (eq size '*) +bits-of-int+ size)))
       (ecase size
   (destructuring-bind (&optional (size '*)) args
     (let ((size (if (eq size '*) +bits-of-int+ size)))
       (ecase size

-       (8 #'(lambda (sap &optional (offset 0)) 
+       (8 #'(lambda (sap &optional (offset 0) weak-p) 
+              (declare (ignore weak-p))

               (signed-sap-ref-8 sap offset)))
               (signed-sap-ref-8 sap offset)))

-       (16 #'(lambda (sap &optional (offset 0)) 
+       (16 #'(lambda (sap &optional (offset 0) weak-p)
+               (declare (ignore weak-p))

                (signed-sap-ref-16 sap offset)))
                (signed-sap-ref-16 sap offset)))

-       (32 #'(lambda (sap &optional (offset 0)) 
+       (32 #'(lambda (sap &optional (offset 0) weak-p) 
+               (declare (ignore weak-p)) 

                (signed-sap-ref-32 sap offset)))
                (signed-sap-ref-32 sap offset)))

-       (64 #'(lambda (sap &optional (offset 0))
+       (64 #'(lambda (sap &optional (offset 0) weak-p) 
+               (declare (ignore weak-p))

                (signed-sap-ref-64 sap offset)))))))
 
 (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)
                (signed-sap-ref-64 sap offset)))))))
 
 (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)


@@ -416,13 +434,17 @@ (defmethod reader-function ((type (eql 'unsigned-byte)) &rest args)
   (destructuring-bind (&optional (size '*)) args
     (let ((size (if (eq size '*) +bits-of-int+ size)))
       (ecase size
   (destructuring-bind (&optional (size '*)) args
     (let ((size (if (eq size '*) +bits-of-int+ size)))
       (ecase size

-       (8 #'(lambda (sap &optional (offset 0)) 
+       (8 #'(lambda (sap &optional (offset 0) weak-p)
+              (declare (ignore weak-p))

               (sap-ref-8 sap offset)))
               (sap-ref-8 sap offset)))

-       (16 #'(lambda (sap &optional (offset 0)) 
+       (16 #'(lambda (sap &optional (offset 0) weak-p)
+               (declare (ignore weak-p)) 

                (sap-ref-16 sap offset)))
                (sap-ref-16 sap offset)))

-       (32 #'(lambda (sap &optional (offset 0)) 
+       (32 #'(lambda (sap &optional (offset 0) weak-p)
+               (declare (ignore weak-p)) 

                (sap-ref-32 sap offset)))
                (sap-ref-32 sap offset)))

-       (64 #'(lambda (sap &optional (offset 0))
+       (64 #'(lambda (sap &optional (offset 0) weak-p)
+               (declare (ignore weak-p))

                (sap-ref-64 sap offset)))))))
   
   
                (sap-ref-64 sap offset)))))))
   
   


@@ -460,6 +482,15 @@ (defmethod size-of ((type (eql 'single-float)) &rest args)
   (declare (ignore type args))
   +size-of-float+)
 
   (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 writer-function ((type (eql 'single-float)) &rest args)
   (declare (ignore type args))
   #'(lambda (value location &optional (offset 0))


@@ -467,7 +498,8 @@ (defmethod writer-function ((type (eql 'single-float)) &rest args)
 
 (defmethod reader-function ((type (eql 'single-float)) &rest args)
   (declare (ignore type args))
 
 (defmethod reader-function ((type (eql 'single-float)) &rest args)
   (declare (ignore type args))

-  #'(lambda (sap &optional (offset 0)) 
+  #'(lambda (sap &optional (offset 0) weak-p)
+      (declare (ignore weak-p))

       (sap-ref-single sap offset)))
 
 
       (sap-ref-single sap offset)))
 
 


@@ -479,6 +511,15 @@ (defmethod size-of ((type (eql 'double-float)) &rest args)
   (declare (ignore type args))
   +size-of-double+)
 
   (declare (ignore type args))
   +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))
   #'(lambda (value location &optional (offset 0))
 (defmethod writer-function ((type (eql 'double-float)) &rest args)
   (declare (ignore type args))
   #'(lambda (value location &optional (offset 0))


@@ -486,7 +527,8 @@ (defmethod writer-function ((type (eql 'double-float)) &rest args)
 
 (defmethod reader-function ((type (eql 'double-float)) &rest args)
   (declare (ignore type args))
 
 (defmethod reader-function ((type (eql 'double-float)) &rest args)
   (declare (ignore type args))

-  #'(lambda (sap &optional (offset 0)) 
+  #'(lambda (sap &optional (offset 0) weak-p)
+      (declare (ignore weak-p))

       (sap-ref-double sap offset)))
 
 
       (sap-ref-double sap offset)))
 
 


@@ -505,7 +547,8 @@ (defmethod writer-function ((type (eql 'base-char)) &rest args)
 
 (defmethod reader-function ((type (eql 'base-char)) &rest args)
   (declare (ignore type args))
 
 (defmethod reader-function ((type (eql 'base-char)) &rest args)
   (declare (ignore type args))

-  #'(lambda (location &optional (offset 0))
+  #'(lambda (location &optional (offset 0) weak-p)
+      (declare (ignore weak-p))

       (code-char (sap-ref-8 location offset))))
 
 
       (code-char (sap-ref-8 location offset))))
 
 


@@ -521,23 +564,32 @@ (defmethod to-alien-form (string (type (eql 'string)) &rest args)
   (declare (ignore type args))
   `(let ((string ,string))
      ;; Always copy strings to prevent seg fault due to GC
   (declare (ignore type args))
   `(let ((string ,string))
      ;; Always copy strings to prevent seg fault due to GC

+     #+cmu

      (copy-memory
       (vector-sap (coerce string 'simple-base-string))
      (copy-memory
       (vector-sap (coerce string 'simple-base-string))

-      (1+ (length 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)
   
 (defmethod to-alien-function ((type (eql 'string)) &rest args)
   (declare (ignore type args))
   #'(lambda (string)

+      #+cmu

       (copy-memory
        (vector-sap (coerce string 'simple-base-string))
       (copy-memory
        (vector-sap (coerce string 'simple-base-string))

-       (1+ (length 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)
       (prog1
 
 (defmethod from-alien-form (string (type (eql 'string)) &rest args)
   (declare (ignore type args))
   `(let ((string ,string))
     (unless (null-pointer-p string)
       (prog1

-         (%naturalize-c-string string)
+         #+cmu(%naturalize-c-string string)
+         #+sbcl(%naturalize-utf8-string string)

        (deallocate-memory string)))))
 
 (defmethod from-alien-function ((type (eql 'string)) &rest args)
        (deallocate-memory string)))))
 
 (defmethod from-alien-function ((type (eql 'string)) &rest args)


@@ -545,7 +597,8 @@ (defmethod from-alien-function ((type (eql 'string)) &rest args)
   #'(lambda (string)
       (unless (null-pointer-p string)
        (prog1
   #'(lambda (string)
       (unless (null-pointer-p string)
        (prog1

-           (%naturalize-c-string string)
+           #+cmu(%naturalize-c-string string)
+           #+sbcl(%naturalize-utf8-string string)

          (deallocate-memory string)))))
 
 (defmethod cleanup-form (string (type (eql 'string)) &rest args)
          (deallocate-memory string)))))
 
 (defmethod cleanup-form (string (type (eql 'string)) &rest args)


@@ -564,29 +617,36 @@ (defmethod copy-from-alien-form (string (type (eql 'string)) &rest args)
   (declare (ignore type args))
   `(let ((string ,string))
     (unless (null-pointer-p string)
   (declare (ignore type args))
   `(let ((string ,string))
     (unless (null-pointer-p string)

-      (%naturalize-c-string 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)
 
 (defmethod copy-from-alien-function ((type (eql 'string)) &rest args)
   (declare (ignore type args))
   #'(lambda (string)
       (unless (null-pointer-p string)

-       (%naturalize-c-string 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)
 
 (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
        (vector-sap (coerce string 'simple-base-string))
        (copy-memory
        (vector-sap (coerce string 'simple-base-string))

-       (1+ (length 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))
 
 (defmethod reader-function ((type (eql 'string)) &rest args)
   (declare (ignore type args))

-  #'(lambda (location &optional (offset 0))
+  #'(lambda (location &optional (offset 0) weak-p)
+      (declare (ignore weak-p))

       (unless (null-pointer-p (sap-ref-sap location offset))
       (unless (null-pointer-p (sap-ref-sap location offset))

-       (%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))
 
 (defmethod destroy-function ((type (eql 'string)) &rest args)
   (declare (ignore type args))


@@ -599,6 +659,7 @@ (defmethod unbound-value ((type (eql 'string)) &rest args)
   (declare (ignore type args))
   (values t nil))
 
   (declare (ignore type args))
   (values t nil))
 

+

 (defmethod alien-type ((type (eql 'pathname)) &rest args)
   (declare (ignore type args))
   (alien-type 'string))
 (defmethod alien-type ((type (eql 'pathname)) &rest args)
   (declare (ignore type args))
   (alien-type 'string))


@@ -644,7 +705,8 @@ (defmethod writer-function ((type (eql 'pathname)) &rest args)
 (defmethod reader-function ((type (eql 'pathname)) &rest args)
   (declare (ignore type args))
   (let ((string-reader (reader-function 'string)))
 (defmethod reader-function ((type (eql 'pathname)) &rest args)
   (declare (ignore type args))
   (let ((string-reader (reader-function 'string)))

-  #'(lambda (location &optional (offset 0))
+  #'(lambda (location &optional (offset 0) weak-p)
+      (declare (ignore weak-p))

       (let ((string (funcall string-reader location offset)))
        (when string
          (parse-namestring string))))))
       (let ((string (funcall string-reader location offset)))
        (when string
          (parse-namestring string))))))


@@ -691,7 +753,8 @@ (defmethod writer-function ((type (eql 'boolean)) &rest args)
 (defmethod reader-function ((type (eql 'boolean)) &rest args)
   (declare (ignore type))
   (let ((reader (apply #'reader-function 'signed-byte args)))
 (defmethod reader-function ((type (eql 'boolean)) &rest args)
   (declare (ignore type))
   (let ((reader (apply #'reader-function 'signed-byte args)))

-  #'(lambda (location &optional (offset 0))
+  #'(lambda (location &optional (offset 0) weak-p)
+      (declare (ignore weak-p))

       (not (zerop (funcall reader location offset))))))
 
 
       (not (zerop (funcall reader location offset))))))
 
 


@@ -743,7 +806,8 @@ (defmethod writer-function ((type (eql 'system-area-pointer)) &rest args)
 
 (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
   (declare (ignore type args))
 
 (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
   (declare (ignore type args))

-  #'(lambda (location &optional (offset 0))
+  #'(lambda (location &optional (offset 0) weak-p)
+      (declare (ignore weak-p))

       (sap-ref-sap location offset)))
 
 
       (sap-ref-sap location offset)))
 
 


@@ -808,3 +872,57 @@ (defmethod reader-function ((type (eql 'copy-of)) &rest args)
 (defmethod writer-function ((type (eql 'copy-of)) &rest args)
   (declare (ignore type))
   (writer-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) weak-p)
+      (declare (ignore weak-p))
+      (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))