[gtk-cffi-cvs] CVS gtk-cffi/g-object
CVS User rklochkov
rklochkov at common-lisp.net
Fri Aug 26 17:16:13 UTC 2011
Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-object
In directory tiger.common-lisp.net:/tmp/cvs-serv16215/g-object
Modified Files:
g-object-cffi.asd g-object-class.lisp g-object.lisp
g-type.lisp g-value.lisp generics.lisp package.lisp
pobject.lisp
Added Files:
defslots.lisp
Log Message:
Added GTK3 support. Dropped GTK2 support.
Refactored CFFI layer.
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-cffi.asd 2011/08/08 15:02:01 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-cffi.asd 2011/08/26 17:16:13 1.3
@@ -16,13 +16,14 @@
:license "LGPL"
:depends-on (cffi-object g-lib-cffi gtk-cffi-utils)
:components
- ((:file :package)
- (:file :loadlib :depends-on (:package))
- (:file :generics :depends-on (:package))
- (:file :g-type :depends-on (:loadlib :generics))
- (:file :pobject :depends-on (:g-type))
- (:file :g-value :depends-on (:pobject))
- (:file :g-object :depends-on (:g-value))
- (:file :g-object-class :depends-on (:g-object))
- (:file :subclass :depends-on (:g-object))))
+ ((:file package)
+ (:file loadlib :depends-on (package))
+ (:file generics :depends-on (package))
+ (:file g-type :depends-on (loadlib generics))
+ (:file pobject :depends-on (g-type))
+ (:file defslots :depends-on (pobject))
+ (:file g-value :depends-on (pobject))
+ (:file g-object :depends-on (g-value))
+ (:file g-object-class :depends-on (g-object))
+ (:file subclass :depends-on (g-object))))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-class.lisp 2011/08/08 15:02:01 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-class.lisp 2011/08/26 17:16:13 1.3
@@ -23,25 +23,18 @@
(constructed :pointer)
(pdummy :pointer :count 7))
-(defmethod gconstructor ((g-object-class g-object-class)
- &key object)
+(defmethod gconstructor ((g-object-class g-object-class) &key object)
(mem-ref (pointer object) :pointer))
(defcfun "g_object_class_list_properties"
- :pointer (obj-class pobject) (n-props :pointer))
+ (garray (object g-param-spec)) (obj-class pobject) (n-props :pointer))
(defclass g-param-spec (object)
())
(defmethod list-properties ((g-object-class g-object-class))
- (with-foreign-object
- (n-props :int)
- (let ((res (g-object-class-list-properties g-object-class n-props)))
- (unwind-protect
- (loop :for i :below (mem-ref n-props :int)
- :collect (make-instance 'g-param-spec
- :pointer (mem-aref res :pointer i)))
- (foreign-free res)))))
+ (with-array
+ (g-object-class-list-properties g-object-class *array-length*)))
(defcfun "g_object_class_find_property" :pointer
(obj-class pobject) (key :string))
@@ -87,11 +80,11 @@
(defun show-properties (g-object)
(let ((gclass (make-instance 'g-object-class :object g-object)))
- (mapc
- (lambda (param)
- (format t "~A~% nick=~A~% blurb=~A~% type=~A
+ (map nil
+ (lambda (param)
+ (format t "~A~% nick=~A~% blurb=~A~% type=~A
owner-type=~A~% flags=~A~%~%"
- (name param) (nick param) (blurb param)
- (g-type->name (g-type param))
- (g-type->name (g-type param :owner t)) (flags param)))
- (list-properties gclass))))
\ No newline at end of file
+ (name param) (nick param) (blurb param)
+ (g-type->lisp (g-type param))
+ (g-type->lisp (g-type param :owner t)) (flags param)))
+ (list-properties gclass))))
\ No newline at end of file
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2011/08/08 15:02:01 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2011/08/26 17:16:13 1.3
@@ -34,11 +34,11 @@
(format t "Creating ~a ~a~%" g-object value)
(g-object-weak-ref value (callback destroy-object) (null-pointer))))
-(defcfun "g_object_set_property" :void (object pobject)
- (name :string) (value pobject))
+(defcfun "g_object_set_property" :void
+ (object pobject) (name :string) (value pobject))
-(defcfun "g_object_get_property" :void (object pobject)
- (name :string) (value pobject))
+(defcfun "g_object_get_property" :void
+ (object pobject) (name :string) (value pobject))
(defgeneric (setf property) (values g-object &rest keys))
@@ -47,8 +47,8 @@
(setf (property object :prop1 :prop2) (list value1 value2))"
(mapc (lambda (key value)
(declare (type (or symbol string) key))
- (debug-out "key: ~a, value: ~a, type: ~a~%" key value
- (property-type g-object key))
+ ;(debug-out "key: ~a, value: ~a, type: ~a~%" key value
+ ; (property-type g-object key))
(let ((skey (string-downcase key)))
(with-g-value (:value value :g-type (property-type g-object skey))
(g-object-set-property g-object skey *g-value*))))
@@ -91,48 +91,15 @@
:swapped)
-(defmacro bitmask (&rest flags)
- "Returns list from lisp values as keywords:
- Example: (bitmask after swapped)
- -> nil, when after=nil and swapped=nil
- -> (:after), when after=t and swapped=nil
- -> (:swapped), when after=nil and swapped=t
- -> (:after :swapped), when both are t"
- `(mapcan
- #'identity
- ,(cons 'list
- (loop :for flag :in flags
- :collecting `(when ,flag
- (list ,(intern (string flag) :keyword)))))))
-
-
(defcfun "g_signal_connect_data" :ulong
- (instance g-object)
+ (instance pobject)
(detailed-signal :string)
(c-handler pfunction)
- (data :pointer)
+ (data pdata)
(destroy-data pfunction)
(connect-flags connect-flags))
-;;; Class STORAGE
-
-(defclass storage (object)
- ((data :accessor data :initarg :data)
- (cffi-object::volatile :initform nil :accessor volatile))
- (:documentation "A storage for any data for callbacks.
- On make-instance it allocates one byte on heap and associates itself
- with the address of that byte."))
-
-(defmethod gconstructor ((storage storage) &key &allow-other-keys)
- (foreign-alloc :char))
-
-(defcallback free-storage :void ((data :pointer) (closure :pointer))
- (declare (ignore closure))
- (unless (null-pointer-p data)
- (setf (pointer (object data)) (null-pointer))
- (remhash (pointer-address data) *objects*)
- (foreign-free data)))
;; Closure staff: marshaller and callbacks
@@ -151,7 +118,7 @@
(defcfun "g_closure_set_marshal" :void (closure :pointer) (marshal :pointer))
(defcfun "g_signal_connect_closure" :ulong
- (instance g-object)
+ (instance pobject)
(detailed-signal :string)
(closure :pointer)
(after :boolean))
@@ -164,11 +131,13 @@
(data :pointer))
(declare (ignore hint data))
(let ((lisp-func (object closure))
- (lisp-params (loop :for i :from 0 :below n-values :collecting
- (value
- (make-instance
- 'g-value
- :pointer (mem-aref params 'g-value-struct i)))))
+ (lisp-params
+ (iter
+ (for i from 0 below n-values)
+ (collect (value
+ (make-instance
+ 'g-value
+ :pointer (mem-aref params 'g-value-struct i))))))
(lisp-return (make-instance 'g-value :pointer return)))
(let ((res (apply lisp-func lisp-params)))
(when (/= (g-type lisp-return) 0)
@@ -186,6 +155,30 @@
(defcfun "g_signal_handler_disconnect" :void (instance g-object) (id :ulong))
+(defmethod connect ((g-object g-object) c-handler
+ &key signal data after swapped)
+ (let* ((str-signal (string-downcase signal))
+ (handler-id
+ (typecase c-handler
+ (function (g-signal-connect-closure
+ g-object str-signal
+ (make-closure
+ (if data
+ (lambda (&rest params)
+ (apply c-handler
+ (if swapped
+ (cons data params)
+ (nconc params (list data)))))
+ c-handler))
+ after))
+ (t (g-signal-connect-data
+ g-object str-signal c-handler data
+ (if (or (null data) (pointerp data) (typep data 'g-object))
+ (null-pointer) (callback free-storage))
+ ;; connect-flags
+ (bitmask after swapped))))))
+ (push (cons str-signal handler-id) (gsignals g-object))))
+
(defgeneric (setf gsignal) (c-handler g-object detailed-signal &rest flags))
(defmethod (setf gsignal) (c-handler
@@ -205,49 +198,25 @@
If c-handler is null (or null pointer), this method removes signal.
In this case detailed-string may be also id of the signal handler
-being removed"
+being removed
+
+Returns assoc: (id-of-handler . detailed-signal)"
(if (or (null c-handler)
(and (pointerp c-handler) (null-pointer-p c-handler)))
+ ;; remove handler
(setf (gsignals g-object)
(mapcan
(lambda (x)
- (if (if (numberp detailed-signal) (= detailed-signal (cdr x))
- (string= (string-downcase detailed-signal)
- (car x)))
- (g-signal-handler-disconnect
- (pointer g-object) (cdr x)) x)) (gsignals g-object)))
- (let* ((str-signal (string-downcase detailed-signal))
- (handler-id
- (if (functionp c-handler)
-
- (g-signal-connect-closure
- (pointer g-object)
- str-signal
- (make-closure
- (if data
- (lambda (&rest params)
- (apply c-handler (if swapped
- (cons data params)
- (nconc params (list data)))))
- c-handler))
- after)
-
- (g-signal-connect-data
- (pointer g-object)
- str-signal
- c-handler
- (cond
- ((pointerp data) data)
- ((null data) (null-pointer))
- ((typep data 'g-object) (pointer data))
- (t (pointer (make-instance 'storage :data data))))
- ;; destroy-notify
- (if (or (null data) (pointerp data) (typep data 'g-object))
- (null-pointer) (callback free-storage))
- ;; connect-flags
- (bitmask after swapped)))))
- (push (cons str-signal handler-id) (gsignals g-object))
- handler-id)))
+ (if (if (numberp detailed-signal)
+ (= detailed-signal (cdr x))
+ (string= (string-downcase detailed-signal) (car x)))
+ (g-signal-handler-disconnect g-object (cdr x))
+ (list x)))
+ (gsignals g-object)))
+ (connect g-object c-handler
+ :signal detailed-signal
+ :swapped swapped :after after :data data)))
+
(defgeneric gsignal (g-object signal))
@@ -255,9 +224,9 @@
(defmethod gsignal ((g-object g-object) detailed-signal)
"method GSIGNAL of class G-OBJECT
returns list of IDs of setted signals"
- (mapcan (lambda (x) (when (string= (string-downcase detailed-signal)
- (car x))
- (list (cdr x)))) (gsignals g-object)))
+ (mapcan (lambda (x) (when (string= (string-downcase detailed-signal) (car x))
+ (list (cdr x))))
+ (gsignals g-object)))
(defmethod (setf signals) (signals (g-object g-object))
"SIGNALS is a list (signal-id signal-value signal-id signal-value ...)
@@ -277,19 +246,6 @@
(properties g-object) rest))
properties))
-(defmacro with-object ((name &optional for-free) init &rest body)
- `(let ((,name ,init))
- (unwind-protect
- (progn
- , at body)
- (free ,(or for-free name)))))
-
-(defmacro setf-init (object &rest fields)
- "Should be used in constructors"
- (cons 'progn
- (mapcar (lambda (field) `(when ,field
- (setf (,field ,object) ,field)))
- fields)))
(defmethod initialize-instance :after ((g-object g-object)
&key signals properties
@@ -306,4 +262,6 @@
(defcfun g-object-newv :pointer (class-type g-type)
(n-params :uint) (params :pointer))
+
+
\ No newline at end of file
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp 2011/08/08 15:02:01 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp 2011/08/26 17:16:13 1.3
@@ -13,7 +13,7 @@
:enum :flags :float :double :string
:pointer :boxed :param :object))
-(defun name->g-type (type)
+(defun keyword->g-type (type)
"Keyword from +fundamental-gtypes+ -> integer"
(* (or (position type +fundamental-g-types+)
(position :object +fundamental-g-types+)) 4))
@@ -33,8 +33,14 @@
"GTypeInstance"
(g-class (:pointer g-type-class)))
+(defun g-type-from-instance (ptr)
+ (foreign-slot-value
+ (foreign-slot-value ptr 'g-type-instance 'g-class)
+ 'g-type-class 'g-type))
+
(defcfun g-type-fundamental g-type (id g-type))
(defcfun g-type-from-name g-type (name :string))
+(defcfun g-type-name :string (id :ulong))
(defcstruct g-type-query
"GTypeQuery"
@@ -45,7 +51,7 @@
(defcfun g-type-query :void (type g-type) (query g-type-query))
-(defun g-type->name (num)
+(defun g-type->keyword (num)
"Integer (GType) -> keyword from +fundamental-gtypes+"
(or (nth (/ (g-type-fundamental num) 4) +fundamental-g-types+) :object))
@@ -56,7 +62,7 @@
"Assoc: GTK type name (string) -> lisp object")
(defun register-type (lisp-class gtk-typename)
- (setq *typenames* (acons gtk-typename lisp-class *typenames*)))
+ (push (cons gtk-typename lisp-class) *typenames*))
(defvar *gtk-packages* nil
;; (mapcar
@@ -69,7 +75,6 @@
(defun register-package (name package)
(push (cons name package) *gtk-packages*))
-(defcfun "g_type_name" :string (id :ulong))
(defun g-type->lisp (g-type)
"Returns lisp class for the gtype and caches result
@@ -106,3 +111,8 @@
package)))))))))
+(defcfun g-type-children (garray g-type) (type g-type) (n-children :pointer))
+
+(defun children (type)
+ (with-array
+ (g-type-children type *array-length*)))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-value.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-value.lisp 2011/08/26 17:16:13 1.2
@@ -26,25 +26,25 @@
(g-type :ulong)
(data g-value-data :count 2))
-(defcfun "g_value_init" :pointer (gvalue pobject) (type :int))
-(defcfun "g_value_set_boolean" :void (gvalue :pointer) (val :boolean))
-(defcfun "g_value_set_char" :void (gvalue :pointer) (val :char))
-(defcfun "g_value_set_uchar" :void (gvalue :pointer) (val :uchar))
-(defcfun "g_value_set_int" :void (gvalue :pointer) (val :int))
-(defcfun "g_value_set_uint" :void (gvalue :pointer) (val :uint))
-(defcfun "g_value_set_long" :void (gvalue :pointer) (val :long))
-(defcfun "g_value_set_ulong" :void (gvalue :pointer) (val :ulong))
-(defcfun "g_value_set_int64" :void (gvalue :pointer) (val :int64))
-(defcfun "g_value_set_uint64" :void (g-value :pointer) (val :uint64))
-(defcfun "g_value_set_float" :void (g-value :pointer) (val :float))
-(defcfun "g_value_set_double" :void (g-value :pointer) (val :double))
-(defcfun "g_value_set_enum" :void (g-value :pointer) (val :int))
-(defcfun "g_value_set_flags" :void (g-value :pointer) (val :uint))
-(defcfun "g_value_set_string" :void (g-value :pointer) (val gtk-string))
-(defcfun "g_value_set_param" :void (g-value :pointer) (val :pointer))
-(defcfun "g_value_set_boxed" :void (g-value :pointer) (val :pointer))
-(defcfun "g_value_set_pointer" :void (g-value :pointer) (val :pointer))
-(defcfun "g_value_set_object" :void (g-value :pointer) (val pobject))
+(defcfun "g_value_init" :pointer (g-value pobject) (type :int))
+(defcfun "g_value_set_boolean" :void (g-value pobject) (val :boolean))
+(defcfun "g_value_set_char" :void (g-value pobject) (val :char))
+(defcfun "g_value_set_uchar" :void (g-value pobject) (val :uchar))
+(defcfun "g_value_set_int" :void (g-value pobject) (val :int))
+(defcfun "g_value_set_uint" :void (g-value pobject) (val :uint))
+(defcfun "g_value_set_long" :void (g-value pobject) (val :long))
+(defcfun "g_value_set_ulong" :void (g-value pobject) (val :ulong))
+(defcfun "g_value_set_int64" :void (g-value pobject) (val :int64))
+(defcfun "g_value_set_uint64" :void (g-value pobject) (val :uint64))
+(defcfun "g_value_set_float" :void (g-value pobject) (val :float))
+(defcfun "g_value_set_double" :void (g-value pobject) (val :double))
+(defcfun "g_value_set_enum" :void (g-value pobject) (val :int))
+(defcfun "g_value_set_flags" :void (g-value pobject) (val :uint))
+(defcfun "g_value_set_string" :void (g-value pobject) (val gtk-string))
+(defcfun "g_value_set_param" :void (g-value pobject) (val :pointer))
+(defcfun "g_value_set_boxed" :void (g-value pobject) (val :pointer))
+(defcfun "g_value_set_pointer" :void (g-value pobject) (val :pointer))
+(defcfun "g_value_set_object" :void (g-value pobject) (val pobject))
(defmethod gconstructor ((g-value g-value) &key
@@ -55,7 +55,7 @@
ptr))
(defmethod (setf value) (val (g-value g-value))
- (g-value-set (pointer g-value) val (g-type g-value)))
+ (g-value-set g-value val (g-type g-value)))
(defcfun g-value-unset :void (g-value pobject))
@@ -67,20 +67,20 @@
(macrolet ((gtypecase (x &rest body)
`(typecase ,x
,@(mapcar (lambda (x) (list (car x)
- (name->g-type (cadr x))))
+ (keyword->g-type (cdr x))))
body))))
(let ((%type (or type
(when value-p
(gtypecase value
- (standard-char :char)
- (fixnum :int)
- (integer :int64)
- (single-float :float)
- (double-float :double)
- (string :string)
- (boolean :boolean)
- (null :boolean)
- (t :pointer))))))
+ (standard-char . :char)
+ (fixnum . :int)
+ (integer . :int64)
+ (single-float . :float)
+ (double-float . :double)
+ (string . :string)
+ (boolean . :boolean)
+ (null . :boolean)
+ (t . :pointer))))))
(when %type
(g-value-init ptr %type)
(when value-p
@@ -125,43 +125,53 @@
(macrolet ((select-accessor (type prefix)
`(ecase ,type
,@(mapcar (lambda (x)
- (list (name->g-type x)
- (list 'function
- (intern (format nil prefix x)))))
+ `(,(keyword->g-type x)
+ (function
+ ,(symbolicate prefix x))))
(remove-if
- (lambda (item) (find item
- '(:invalid :interface :void)))
+ (rcurry #'member '(:invalid :interface :void))
+fundamental-g-types+)))))
(defun g-value-set (ptr value type)
"PTR - foreign pointer, VALUE - lisp value, TYPE - GType id"
- (let ((val (if (or (keywordp value)
- (consp value))
- (convert-to-foreign value (g-type->lisp type)); enum|flags
- value)))
- (when (/= type 0)
- (funcall (select-accessor
- (g-type-fundamental type) "G-VALUE-SET-~A") ptr val))))
-
+; (debug-out "g-value-set: ~a ~a~%" value (g-type->keyword type))
+ (let ((ftype (g-type-fundamental type)))
+ (let ((val (case ftype
+ ((#.(keyword->g-type :enum)
+ #.(keyword->g-type :flags))
+ (convert-to-foreign value (g-type->lisp type)))
+ (#.(keyword->g-type :double) (coerce value 'double-float))
+ (#.(keyword->g-type :float) (coerce value 'single-float))
+ ((#.(keyword->g-type :int)
+ #.(keyword->g-type :uint)
+ #.(keyword->g-type :long)
+ #.(keyword->g-type :ulong)
+ #.(keyword->g-type :int64)
+ #.(keyword->g-type :uint64)) (round value))
+ (t value))))
+; (debug-out " converted value ~a~%" val)
+ (when (/= type 0)
+ (funcall (select-accessor ftype :g-value-set-) ptr val)))))
+
(defun g-value-get (value)
(unless (null-pointer-p value)
(let* ((g-type (type-g-value value))
(fundamental-type (g-type-fundamental g-type)))
(case fundamental-type
- (#.(name->g-type :boxed)
+ (#.(keyword->g-type :boxed)
(object (g-value-get-boxed value)
:class (g-type->lisp g-type)))
- (#.(name->g-type :enum)
+ (#.(keyword->g-type :enum)
(convert-from-foreign
(g-value-get-enum value) (g-type->lisp g-type)))
- (#.(name->g-type :flags)
+ (#.(keyword->g-type :flags)
(convert-from-foreign
(g-value-get-flags value) (g-type->lisp g-type)))
- (#.(name->g-type :interface)
+ (#.(keyword->g-type :interface)
(g-value-get-object value))
(t
(funcall (select-accessor
- fundamental-type "G-VALUE-GET-~A") value)))))))
+ fundamental-type :g-value-get-) value)))))))
(defmethod value ((g-value g-value))
(g-value-get (pointer g-value)))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/generics.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/generics.lisp 2011/08/26 17:16:13 1.2
@@ -13,5 +13,6 @@
(defgeneric nick (g-object-class))
(defgeneric flags (g-object-class))
+(defgeneric connect (g-object handler &rest keys))
(defgeneric (setf signals) (signals g-object))
(defgeneric (setf properties) (properties g-object))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2011/08/08 15:02:01 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2011/08/26 17:16:13 1.3
@@ -8,7 +8,8 @@
(in-package #:cl-user)
(defpackage #:g-object-cffi
- (:use #:common-lisp #:cffi #:cffi-object #:g-lib-cffi #:gtk-cffi-utils)
+ (:use #:common-lisp #:cffi #:alexandria #:iterate
+ #:cffi-object #:g-lib-cffi #:gtk-cffi-utils)
(:import-from #:cffi-object *objects*)
(:export
@@ -17,6 +18,8 @@
#:signals
#:property
#:gsignal
+
+ #:connect
#:storage
;; slot
@@ -29,9 +32,6 @@
#:pobject
#:pdata
#:g-list-object
- #:g-type-interface
- #:g-type-class
- #:g-type-instance
#:with-g-value
#:*g-value*
@@ -40,15 +40,29 @@
#:unset
#:init
- #:g-type->name
+; #:g-type->name
#:g-type->lisp
- #:name->g-type
+ #:keyword->g-type
#:g-type
+ #:g-type-name
+ #:g-type-from-name
+ #:g-type-from-instance
+ #:g-type-info
+ #:g-type-flags
+ #:g-type-register-static
+ #:g-type-register-static-simple
+ #:g-interface-info
+ #:g-type-add-interface-static
+ #:g-type-interface
+ #:g-type-class
+ #:g-type-instance
+
#:register-type
#:register-package
#:setf-init
+ #:init-slots
#:ref
#:unref
@@ -57,17 +71,17 @@
#:find-child-property
#:g-object-class
- #:gparam-spec
+ #:g-param-spec
#:g-object-newv
#:new
- #:g-type-info
- #:g-type-flags
- #:g-type-register-static
- #:g-type-register-static-simple
- #:g-interface-info
- #:g-type-add-interface-static
- #:g-type-interface
- #:g-type-class
- #:g-type-instance))
-
+ #:defgtkslot
+ #:defgtkslots
+ #:defgdkslot
+ #:defgdkslots
+ #:defgtkgetter
+ #:defgdkgetter
+ #:defgtksetter
+ #:defgdksetter
+ #:defgtkfun
+ #:defgdkfun))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp 2011/08/08 15:02:01 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp 2011/08/26 17:16:13 1.3
@@ -9,17 +9,43 @@
(define-foreign-type cffi-pobject (cffi-object)
()
- (:actual-type :pointer)
- (:simple-parser pobject))
+ (:actual-type :pointer))
+
+(define-parse-method pobject (&optional class)
+ (make-instance 'cffi-pobject :class class))
-(defmethod translate-from-foreign (ptr (name cffi-pobject))
+(defmethod translate-from-foreign (ptr (cffi-pobject cffi-pobject))
"The first int at GObject instance is its type pointer, take it and
make up lisp object"
(declare (type foreign-pointer ptr))
(unless (null-pointer-p ptr)
- (let ((class (g-type->lisp (mem-ref (mem-ref ptr :pointer) :uint))))
+ (let ((class (or (cffi-object::obj-class cffi-pobject)
+ (g-type->lisp (g-type-from-instance ptr)))))
(object ptr :class class))))
+;; register as object type for g-list
+(defmethod g-lib-cffi::object-type ((type-name (eql 'pobject))) t)
+
+;;; Class STORAGE
+
+(defclass storage (object)
+ ((data :accessor data :initarg :data)
+ (cffi-object::volatile :initform nil :accessor volatile))
+ (:documentation "A storage for any data for callbacks.
+ On make-instance it allocates one byte on heap and associates itself
+ with the address of that byte."))
+
+(defmethod gconstructor ((storage storage) &key &allow-other-keys)
+ (foreign-alloc :char))
+
+(defcallback free-storage :void ((data :pointer) (closure :pointer))
+ (declare (ignore closure))
+ (unless (null-pointer-p data)
+ (setf (pointer (object data)) (null-pointer))
+ (remhash (pointer-address data) *objects*)
+ (foreign-free data)))
+
+
(define-foreign-type cffi-pdata (cffi-pobject)
()
(:actual-type :pointer)
@@ -32,19 +58,30 @@
(let ((obj (object ptr :class 'storage)))
(when obj (data obj))))
-(defmethod translate-to-foreign :around (any-data (name cffi-pdata))
- (call-next-method (make-instance 'storage :data any-data) name))
+(defmethod translate-to-foreign (any-data (name cffi-pdata))
+ (if (or (null any-data) (pointerp any-data))
+ (call-next-method)
+ (translate-to-foreign (make-instance 'storage :data any-data) name)))
+
+(defmethod translate-to-foreign ((any-data storage) (name cffi-pdata))
+ (call-next-method))
+
+(defmethod translate-to-foreign :around ((any-data storage) (name cffi-pdata))
+ (call-next-method any-data name))
+
+;; (define-foreign-type g-list-object (g-list)
+;; ()
+;; (:actual-type :pointer)
+;; (:simple-parser g-list-object)
+;; (:documentation "GList with pointers to GObjects"))
+
+;; (defmethod translate-from-foreign :around (ptr (name g-list-object))
+;; (declare (ignorable ptr name))
+;; (mapcar (lambda (x) (convert-from-foreign x 'pobject))
+;; (call-next-method)))
-(define-foreign-type g-list-object (g-list)
- ()
- (:actual-type :pointer)
- (:simple-parser g-list-object)
- (:documentation "GList with pointers to GObjects"))
+(defctype g-list-object (g-list pobject))
-(defmethod translate-from-foreign :around (ptr (name g-list-object))
- (declare (ignorable ptr name))
- (mapcar (lambda (x) (convert-from-foreign x 'pobject))
- (call-next-method)))
(defcfun g-type-interface-peek-parent pobject (iface pobject))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2011/08/26 17:16:14 NONE
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2011/08/26 17:16:14 1.1
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; defslots.lisp --- def*slot(s) macros for group binding setters and getters
;;;
;;; Copyright (C) 2011, Roman Klochkov <kalimehtar at mail.ru>
;;;
(in-package #:g-object-cffi)
(defun defslot (prefix current-class slot-name slot-type)
(let ((name-lisp (if (consp slot-name) (car slot-name) slot-name))
(name-gtk (if (consp slot-name) (cdr slot-name) slot-name)))
(let ((getter (symbolicate prefix current-class '-get- name-gtk))
(setter (symbolicate prefix current-class '-set- name-gtk)))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(push ',name-lisp (get ',current-class 'slots)))
(defcfun ,getter ,slot-type (object pobject))
(defcfun ,setter :void (widget pobject) (value ,slot-type))
(unless (fboundp ',name-lisp)
(defgeneric ,name-lisp (,current-class)))
(unless (fboundp '(setf ,name-lisp))
(defgeneric (setf ,name-lisp) (value ,current-class)))
(defmethod ,name-lisp ((object ,current-class)) (,getter object))
(defmethod (setf ,name-lisp) (value (object ,current-class))
(,setter object value) value)))))
(defmacro defgtkslot (current-class slot-name slot-type)
(defslot 'gtk- current-class slot-name slot-type))
(defun defslots (def-macro current-class slots)
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (get ',current-class 'slots) nil))
,@(iter
(for x on slots by #'cddr)
(collect (list def-macro current-class (first x) (second x))))))
(defmacro defgtkslots (current-class &rest slots)
(defslots 'defgtkslot current-class slots))
(defmacro defgdkslot (current-class slot-name slot-type)
(defslot 'gdk- current-class slot-name slot-type))
(defmacro defgdkslots (current-class &rest slots)
(defslots 'defgdkslot current-class slots))
(defun def-fun (prefix name res-type class params &key get)
(let ((fun-name (symbolicate prefix class (if get '-get- '-) name))
(param-list (mapcar #'car params)))
`(progn
(defcfun ,fun-name ,res-type (,class pobject) , at params)
(unless (fboundp ',name)
(defgeneric ,name (,class , at param-list)))
(defmethod ,name ((,class ,class) , at param-list)
(,fun-name ,class , at param-list)))))
(defun defsetter (prefix name slot-type class)
(let ((setter (symbolicate prefix class '-set- name)))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(push ',name (get ',class 'slots)))
(defcfun ,setter :void (widget pobject) (value ,slot-type))
(unless (fboundp '(setf ,name))
(defgeneric (setf ,name) (value ,class)))
(defmethod (setf ,name) (value (object ,class))
(,setter object value) value))))
(defmacro defgtkfun (name res-type class &rest params)
(def-fun 'gtk- name res-type class params))
(defmacro defgdkfun (name res-type class &rest params)
(def-fun 'gdk- name res-type class params))
(defmacro defgtkgetter (name res-type class &rest params)
(def-fun 'gtk- name res-type class params :get t))
(defmacro defgdkgetter (name res-type class &rest params)
(def-fun 'gdk- name res-type class params :get t))
(defmacro defgtksetter (name slot-type class)
(defsetter 'gtk- name slot-type class))
(defmacro defgdksetter (name slot-type class)
(defsetter 'gdk- name slot-type class))
(defmacro with-object ((name &optional for-free) init &rest body)
`(let ((,name ,init))
(unwind-protect
(progn
, at body)
(free ,(or for-free name)))))
(defmacro setf-init (object &rest fields)
"Should be used in constructors"
`(progn
,@(mapcar (lambda (field-all)
(let ((field (if (consp field-all)
(first field-all) field-all))
(field-p (if (consp field-all)
(third field-all) field-all)))
`(when ,field-p
(setf (,field ,object) ,field))))
fields)))
(defmacro init-slots (class add-keys &body body)
"For DEFSLOTS* auto-constructor"
(let ((slots (mapcar (lambda (x) (list x nil (symbolicate x '-p)))
(get class 'slots))))
`(defmethod shared-initialize :after ((,class ,class) slot-names
&key , at slots , at add-keys
&allow-other-keys)
(setf-init ,class , at slots)
, at body)))
More information about the gtk-cffi-cvs
mailing list