;; 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")
-;;;;
-
-;; 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
(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
(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+))
(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))
(deallocate-memory string))))
(defmethod cleanup-function ((type (eql 'string)) &rest args)
+ (declare (ignore args))
#'(lambda (string)
(unless (null-pointer-p string)
(deallocate-memory string))))
;; 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")
(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))
-(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
(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"
- (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"
- (apply #'invoke-callback callback-id type args))))
+ (apply #'invoke-callback callback-id return-type args))))
;;;; 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")
;; 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")
(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
`(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))))
`(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))))
;; 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")
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)
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)))
- (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))
-(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)
;; 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")
(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)
(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
;; 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")
(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)