Added abstraction layer for C callback functions

diff --git a/glib/ffi.lisp b/glib/ffi.lisp
index 039185882324a1bc171ad4da76db2784d8ede7b2..46f69dea8ae94dceb713061662b03d2c8b5ff23e 100644 (file)
--- a/glib/ffi.lisp
+++ b/glib/ffi.lisp
@@ -15,28 +15,10 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 

-;; $Id: ffi.lisp,v 1.2 2004-11-06 21:39:58 espen Exp $
+;; $Id: ffi.lisp,v 1.3 2004-11-07 01:23:38 espen Exp $

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

-;;;;
-
-;; Sizes of fundamental C types in bytes (8 bits)
-(defconstant +size-of-short+ 2)
-(defconstant +size-of-int+ 4)
-(defconstant +size-of-long+ 4)
-(defconstant +size-of-pointer+ 4)
-(defconstant +size-of-float+ 4)
-(defconstant +size-of-double+ 8)
-
-;; Sizes of fundamental C types in bits
-(defconstant +bits-of-byte+ 8)
-(defconstant +bits-of-short+ 16)
-(defconstant +bits-of-int+ 32)
-(defconstant +bits-of-long+ 32)
-
-
-

 
 ;;;; Foreign function call interface
 
 
 ;;;; Foreign function call interface
 


@@ -197,7 +179,23 @@ (defun mkbinding (name return-type &rest arg-types)
             (apply #'alien:alien-funcall alien args))
          (mapc #'funcall cleanup-arguments args)))))
 
             (apply #'alien: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)))
+
+

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


@@ -235,6 +233,21 @@ (def-type-method reader-function ())
 (def-type-method destroy-function ())
 
 
 (def-type-method destroy-function ())
 
 

+;; Sizes of fundamental C types in bytes (8 bits)
+(defconstant +size-of-short+ 2)
+(defconstant +size-of-int+ 4)
+(defconstant +size-of-long+ 4)
+(defconstant +size-of-pointer+ 4)
+(defconstant +size-of-float+ 4)
+(defconstant +size-of-double+ 8)
+
+;; Sizes of fundamental C types in bits
+(defconstant +bits-of-byte+ 8)
+(defconstant +bits-of-short+ 16)
+(defconstant +bits-of-int+ 32)
+(defconstant +bits-of-long+ 32)
+
+

 (deftype int () '(signed-byte #.+bits-of-int+))
 (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+))
 (deftype long () '(signed-byte #.+bits-of-long+))
 (deftype int () '(signed-byte #.+bits-of-int+))
 (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+))
 (deftype long () '(signed-byte #.+bits-of-long+))


@@ -394,7 +407,7 @@ (defmethod size-of ((type (eql 'single-float)) &rest args)
 (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))

-      (setf (sap-ref-single location offset) (coerce value 'single-float)))))
+      (setf (sap-ref-single location offset) (coerce value 'single-float))))

 
 (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))


@@ -482,6 +495,7 @@ (defmethod cleanup-form (string (type (eql 'string)) &rest args)
       (deallocate-memory string))))
 
 (defmethod cleanup-function ((type (eql 'string)) &rest args)
       (deallocate-memory string))))
 
 (defmethod cleanup-function ((type (eql 'string)) &rest args)

+  (declare (ignore args))

   #'(lambda (string)
       (unless (null-pointer-p string)
        (deallocate-memory string))))
   #'(lambda (string)
       (unless (null-pointer-p string)
        (deallocate-memory string))))

diff --git a/glib/gcallback.lisp b/glib/gcallback.lisp
index 520d7a80e92811fd127b4d4aeef08f434051f693..e4212271ba634a3d38d52c200267909ead912e5f 100644 (file)
--- a/glib/gcallback.lisp
+++ b/glib/gcallback.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 

-;; $Id: gcallback.lisp,v 1.12 2004-11-06 21:39:58 espen Exp $
+;; $Id: gcallback.lisp,v 1.13 2004-11-07 01:23:38 espen Exp $

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


@@ -35,17 +35,17 @@ (defun register-callback-function (function)
   (check-type function (or null symbol function))
   (register-user-data function))
 
   (check-type function (or null symbol function))
   (register-user-data function))
 

-(def-callback closure-callback-marshal (c-call:void 
-                                       (gclosure system-area-pointer) 
-                                       (return-value system-area-pointer)
-                                       (n-params c-call:unsigned-int) 
-                                       (param-values system-area-pointer)
-                                       (invocation-hint system-area-pointer) 
-                                       (callback-id c-call:unsigned-int))
+(defcallback closure-callback-marshal (nil
+                                      (gclosure pointer)
+                                      (return-value gvalue)
+                                      (n-params unsigned-int) 
+                                      (param-values pointer)
+                                      (invocation-hint pointer) 
+                                      (callback-id unsigned-int))

   (callback-trampoline callback-id n-params param-values return-value))
 
   (callback-trampoline callback-id n-params param-values return-value))
 

-(def-callback %destroy-user-data (c-call:void (id c-call:unsigned-int))
-  (destroy-user-data id)) 
+(defcallback %destroy-user-data (nil (id unsigned-int))
+  (destroy-user-data id))

  
 (defun make-callback-closure (function)
   (callback-closure-new 
  
 (defun make-callback-closure (function)
   (callback-closure-new 


@@ -64,21 +64,21 @@ (defun callback-trampoline (callback-id n-params param-values return-value)
        (gvalue-set return-value result)))))
 
 
        (gvalue-set return-value result)))))
 
 

-(defun invoke-callback (callback-id type &rest args)
+(defun invoke-callback (callback-id return-type &rest args)

   (restart-case
       (apply (find-user-data callback-id) args)
     (continue nil :report "Return from callback function"
   (restart-case
       (apply (find-user-data callback-id) args)
     (continue nil :report "Return from callback function"

-             (when type
-               (format *query-io* "Enter return value of type ~S: " type)
+             (when return-type
+               (format *query-io* "Enter return value of type ~S: " return-type)

                (force-output *query-io*)
                (eval (read *query-io*))))
     (re-invoke nil :report "Re-invoke callback function"
                (force-output *query-io*)
                (eval (read *query-io*))))
     (re-invoke nil :report "Re-invoke callback function"

-              (apply #'invoke-callback callback-id type args))))
+              (apply #'invoke-callback callback-id return-type args))))

 
 
 ;;;; Timeouts and idle functions
 
 
 
 ;;;; Timeouts and idle functions
 

-(def-callback source-callback-marshal (c-call:void (callback-id c-call:unsigned-int))
+(defcallback source-callback-marshal (nil (callback-id unsigned-int))

   (callback-trampoline callback-id 0 nil (make-pointer 0)))
 
 (defbinding (timeout-add "g_timeout_add_full")
   (callback-trampoline callback-id 0 nil (make-pointer 0)))
 
 (defbinding (timeout-add "g_timeout_add_full")

diff --git a/glib/glib.lisp b/glib/glib.lisp
index 149d392e82dfe0c687f057179d9cbf006356bf31..54298467dbe42489cc780a4768991054f0691a40 100644 (file)
--- a/glib/glib.lisp
+++ b/glib/glib.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 

-;; $Id: glib.lisp,v 1.16 2004-11-06 21:39:58 espen Exp $
+;; $Id: glib.lisp,v 1.17 2004-11-07 01:23:38 espen Exp $

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


@@ -71,6 +71,16 @@ (defun destroy-user-data (id)
       (funcall (cdr user-data) (car user-data))))
   (remhash id *user-data*))
 
       (funcall (cdr user-data) (car user-data))))
   (remhash id *user-data*))
 

+(defmacro def-callback-marshal (name (return-type &rest args))
+  (let ((names (loop 
+               for arg in args 
+               collect (if (atom arg) (gensym) (first arg))))
+       (types (loop 
+               for arg in args 
+               collect (if (atom arg) arg (second arg)))))
+    `(defcallback ,name (,return-type ,@(mapcar #'list names types)
+                        (callback-id unsigned-int))
+      (invoke-callback callback-id ',return-type ,@names))))

 
 
 ;;;; Quarks
 
 
 ;;;; Quarks


@@ -197,7 +207,7 @@ (defmethod to-alien-form (list (type (eql 'glist)) &rest args)
     `(make-glist ',element-type ,list)))
 
 (defmethod to-alien-function ((type (eql 'glist)) &rest args)
     `(make-glist ',element-type ,list)))
 
 (defmethod to-alien-function ((type (eql 'glist)) &rest args)

-  (declare (ignore type args))
+  (declare (ignore type))

   (destructuring-bind (element-type) args    
     #'(lambda (list)
        (make-glist element-type list))))
   (destructuring-bind (element-type) args    
     #'(lambda (list)
        (make-glist element-type list))))


@@ -277,7 +287,7 @@ (defmethod to-alien-form (list (type (eql 'gslist)) &rest args)
     `(make-sglist ',element-type ,list)))
 
 (defmethod to-alien-function ((type (eql 'gslist)) &rest args)
     `(make-sglist ',element-type ,list)))
 
 (defmethod to-alien-function ((type (eql 'gslist)) &rest args)

-  (declare (ignore type args))
+  (declare (ignore type))

   (destructuring-bind (element-type) args    
     #'(lambda (list)
        (make-gslist element-type list))))
   (destructuring-bind (element-type) args    
     #'(lambda (list)
        (make-gslist element-type list))))

diff --git a/glib/gobject.lisp b/glib/gobject.lisp
index 620b7ba4cb5c8237e45b783b203d96a72a02eede..09857863f42e275991fe4f7ee223fc35dab428ff 100644 (file)
--- a/glib/gobject.lisp
+++ b/glib/gobject.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 

-;; $Id: gobject.lisp,v 1.17 2004-11-06 21:39:58 espen Exp $
+;; $Id: gobject.lisp,v 1.18 2004-11-07 01:23:38 espen Exp $

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


@@ -63,7 +63,7 @@ (defmethod initialize-instance ((object gobject) &rest initargs)
           for (pname type value) in args
           as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
           do (funcall string-writer pname tmp)
           for (pname type value) in args
           as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
           do (funcall string-writer pname tmp)

-             (gvalue-init (sap+ tmp string-size) type value))
+          (gvalue-init (sap+ tmp string-size) type value))

          (unwind-protect
               (setf  
                (slot-value object 'location) 
          (unwind-protect
               (setf  
                (slot-value object 'location) 


@@ -72,12 +72,12 @@ (defmethod initialize-instance ((object gobject) &rest initargs)
             repeat (length args)
             as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
             do (funcall string-destroy tmp)
             repeat (length args)
             as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
             do (funcall string-destroy tmp)

-               (gvalue-unset (sap+ tmp string-size)))
+            (gvalue-unset (sap+ tmp string-size)))

            (deallocate-memory params)))
            (deallocate-memory params)))

-      (setf  
-       (slot-value object 'location) 
-       (%gobject-new (type-number-of object)))))
-  
+       (setf  
+        (slot-value object 'location) 
+        (%gobject-new (type-number-of object)))))
+

   (%object-weak-ref object)
   (apply #'call-next-method object initargs))
 
   (%object-weak-ref object)
   (apply #'call-next-method object initargs))
 


@@ -88,7 +88,7 @@ (defmethod initialize-instance :around ((object gobject) &rest initargs)
   (%object-weak-ref object))
 
 
   (%object-weak-ref object))
 
 

-(def-callback weak-notify (c-call:void (data c-call:int) (location system-area-pointer))
+(defcallback weak-notify (nil (data int) (location pointer))

   (let ((object (find-cached-instance location)))
     (when object
 ;;       (warn "~A being finalized by the GObject system while still in existence in lisp" object)
   (let ((object (find-cached-instance location)))
     (when object
 ;;       (warn "~A being finalized by the GObject system while still in existence in lisp" object)

diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp
index 845fdd8a953d3f933ca0e58c23383a2e2e334be9..a4451cff30b13ca442432385e787f14bebeded1a 100644 (file)
--- a/gtk/gtk.lisp
+++ b/gtk/gtk.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 

-;; $Id: gtk.lisp,v 1.15 2004-11-06 21:39:58 espen Exp $
+;; $Id: gtk.lisp,v 1.16 2004-11-07 01:23:38 espen Exp $

 
 
 (in-package "GTK")
 
 
 (in-package "GTK")


@@ -1096,10 +1096,7 @@ (defbinding menu-reorder-child (menu menu-item position) nil
   (menu-item menu-item)
   ((%menu-position menu position) int))
 
   (menu-item menu-item)
   ((%menu-position menu position) int))
 

-(def-callback menu-position-callback-marshal 
-    (c-call:void (x c-call:int) (y c-call:int) (push-in c-call:int) 
-                (callback-id c-call:unsigned-int))
-  (invoke-callback callback-id nil x y (not (zerop push-in))))
+(def-callback-marshal %menu-popup-callback (nil (x int) (y int) (push-in boolean)))

 
 (defbinding %menu-popup () nil
   (menu menu)
 
 (defbinding %menu-popup () nil
   (menu menu)


@@ -1117,7 +1114,7 @@ (defun menu-popup (menu button activate-time &key callback parent-menu-shell
        (unwind-protect
            (%menu-popup
             menu parent-menu-shell parent-menu-item
        (unwind-protect
            (%menu-popup
             menu parent-menu-shell parent-menu-item

-            (callback menu-position-callback-marshal)
+            (callback %menu-popup-callback)

             callback-id button activate-time)
          (destroy-user-data callback-id)))
     (%menu-popup
             callback-id button activate-time)
          (destroy-user-data callback-id)))
     (%menu-popup

diff --git a/gtk/gtkcontainer.lisp b/gtk/gtkcontainer.lisp
index 530b1b495c2a655d0eb23d060f77bb955585cd37..8a24bd0b374323265c988ae252a0a728dbb6e5f7 100644 (file)
--- a/gtk/gtkcontainer.lisp
+++ b/gtk/gtkcontainer.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 

-;; $Id: gtkcontainer.lisp,v 1.10 2004-11-01 00:08:50 espen Exp $
+;; $Id: gtkcontainer.lisp,v 1.11 2004-11-07 01:23:38 espen Exp $

 
 (in-package "GTK")
             
 
 (in-package "GTK")
             


@@ -67,9 +67,7 @@ (defbinding %container-child-set-property () nil
 (defbinding container-check-resize () nil
   (container container))
 
 (defbinding container-check-resize () nil
   (container container))
 

-(def-callback %foreach-callback (c-call:void (widget system-area-pointer) 
-                                           (callback-id c-call:unsigned-int))
-  (invoke-callback callback-id nil (ensure-proxy-instance 'widget widget nil)))
+(def-callback-marshal %foreach-callback (nil widget))

 
 (defbinding %container-foreach (container callback-id) nil
   (container container)
 
 (defbinding %container-foreach (container callback-id) nil
   (container container)