[gtk-cffi-cvs] CVS gtk-cffi/cffi
CVS User rklochkov
rklochkov at common-lisp.net
Sat Sep 10 16:26:10 UTC 2011
Update of /project/gtk-cffi/cvsroot/gtk-cffi/cffi
In directory tiger.common-lisp.net:/tmp/cvs-serv27495/cffi
Modified Files:
object.lisp struct.lisp
Log Message:
Some refactoring. Now we can use (show #(1 2 3)) or (show '(1 2 3)) to lookup
through the sequence in GTK list view
--- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2011/08/28 10:31:30 1.4
+++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2011/09/10 16:26:09 1.5
@@ -39,14 +39,13 @@
Should return a pointer to GTK instance, for example, by g_object_new."))
(defmethod gconstructor (something-bad &rest rest)
- (format t "No constructor for ~a ~a~%" something-bad rest)
- nil)
+ (warn "No constructor for ~a ~a~%" something-bad rest))
(defmethod shared-initialize :after ((object object) slot-names
&rest initargs
&key pointer &allow-other-keys)
- (setf (pointer object)
- (or pointer (apply #'gconstructor (cons object initargs)))))
+ (unless pointer
+ (setf (pointer object) (apply #'gconstructor object initargs))))
(defmethod pointer (something-bad)
(declare (ignore something-bad))
@@ -57,7 +56,7 @@
(:documentation "Removes object pointer from lisp hashes."))
(defmethod free ((object object))
- (when (pointer object)
+ (unless (null-pointer-p (pointer object))
(debug-out "Freeing ~a@~a~%" (type-of object) (pointer object))
(remhash (pointer-address (pointer object)) *objects*)
(remhash (id object) *objects-ids*)
@@ -74,7 +73,6 @@
(progn
(unless (or (null try-find)
(eq (class-of try-find) (find-class class)))
- ;; found something of wrong type, free it
(progn
(free try-find)
(setf try-find nil)))
--- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp 2011/08/28 10:31:30 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp 2011/09/10 16:26:09 1.3
@@ -15,11 +15,12 @@
Struct may be used in OBJECT cffi-type or STRUCT cffi-type"))
(defmethod gconstructor ((struct struct) &key &allow-other-keys)
- nil)
+ (null-pointer))
(defmacro save-setter (class name)
+ "Use this to register setters for SETF-INIT and INIT-SLOTS macro"
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (push ',name (get ',class 'slots))))
+ (pushnew ',name (get ',class 'slots))))
(defmacro clear-setters (class)
`(eval-when (:compile-toplevel :load-toplevel :execute)
@@ -37,7 +38,7 @@
(setf (,field ,object) ,field))))
fields)))
-(defmacro init-slots (class add-keys &body body)
+(defmacro init-slots (class &optional add-keys &body body)
"For SETF-INIT auto-constructor"
(let ((slots (mapcar (lambda (x) (list x nil (symbolicate x '-p)))
(get class 'slots))))
@@ -58,11 +59,15 @@
,@(mapcar
(lambda (x)
`(progn
+ (unless (fboundp ',x)
+ (defgeneric ,x (class-name)))
(defmethod ,x ((,class-name ,class-name))
(if (slot-boundp ,class-name 'value)
(cdr (assoc ',x (slot-value ,class-name 'value)))
(foreign-slot-value (pointer ,class-name)
',struct-name ',x)))
+ (unless (fboundp '(setf ,x))
+ (defgeneric (setf ,x) (val ,class-name)))
(defmethod (setf ,x) (val (,class-name ,class-name))
(if (slot-boundp ,class-name 'value)
(push val (slot-value ,class-name 'value))
@@ -141,26 +146,42 @@
(struct->clos type var)
(mem-ref var type))))
-(defmacro with-foreign-out ((var type &optional count) &body body)
+(defmacro with-foreign-out ((var type &optional count) return-result &body body)
"The same as WITH-FOREIGN-OBJECT, but returns value of object"
- `(with-foreign-object (,var ,type ,@(when count count))
- , at body
- (from-foreign ,var ,type ,count)))
-
-(defmacro with-foreign-outs (bindings &body body)
- "The same as WITH-FOREIGN-OBJECTS, but returns (values ...) of binded vars"
- `(with-foreign-objects ,bindings
- , at body
- (values ,@(mapcar (lambda (x)
- (destructuring-bind (var type &optional count) x
- `(from-foreign ,var ,type ,count)))
- bindings))))
-
-(defmacro with-foreign-outs-list (bindings &body body)
- "The same as WITH-FOREIGN-OBJECTS, but returns list of binded vars"
- `(with-foreign-objects ,bindings
- , at body
- (list ,@(mapcar (lambda (x)
- (destructuring-bind (var type &optional count) x
- `(from-foreign ,var ,type ,count)))
- bindings))))
\ No newline at end of file
+ (let ((value `(from-foreign ,var ,type ,count)))
+ `(with-foreign-object (,var ,type ,@(when count (list count)))
+ ,(if (eq return-result :ignore)
+ `(progn , at body ,value)
+ `(let ((res , at body))
+ ,(ecase return-result
+ (:if-success `(when res ,value))
+ (:return `(values res ,value))))))))
+
+(flet
+ ((make-with-foreign-outs (res-fun bindings return-result body)
+ (let ((values-form (mapcar (lambda (x)
+ (destructuring-bind
+ (var type &optional count) x
+ `(from-foreign ,var ,type ,count)))
+ bindings)))
+ `(with-foreign-objects ,bindings
+ ,(if (eq return-result :ignore)
+ `(progn , at body (,res-fun , at values-form))
+ `(let ((res , at body))
+ ,(ecase return-result
+ (:if-success
+ `(when res (,res-fun , at values-form)))
+ (:return
+ `(,res-fun res , at values-form)))))))))
+
+ (defmacro with-foreign-outs (bindings return-result &body body)
+ "The same as WITH-FOREIGN-OBJECTS, but returns (values ...)
+of result and binded vars, RETURN-RESULT may be
+:RETURN - return result and values
+:IF-SUCCESS - return values if result t
+:IGNORE - discard result"
+ (make-with-foreign-outs 'values bindings return-result body))
+
+ (defmacro with-foreign-outs-list (bindings return-result &body body)
+ "The same as WITH-FOREIGN-OBJECTS, but returns list"
+ (make-with-foreign-outs 'list bindings return-result body)))
More information about the gtk-cffi-cvs
mailing list