/[gtk-cffi]/gtk-cffi/g-object/pobject.lisp
ViewVC logotype

Contents of /gtk-cffi/g-object/pobject.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (show annotations)
Fri Aug 24 19:27:54 2012 UTC (19 months, 3 weeks ago) by rklochkov
Branch: MAIN
CVS Tags: HEAD
Changes since 1.9: +1 -1 lines
Fixed CFFI-OBJECTS:FREE-PTR generic usage (now specialized with EQL)
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; pobject.lisp --- CFFI type for class OBJECT with GType guessing
4 ;;;
5 ;;; Copyright (C) 2007, Roman Klochkov <kalimehtar@mail.ru>
6 ;;;
7
8 (in-package #:g-object-cffi)
9
10 (define-foreign-type cffi-pobject (cffi-object)
11 ()
12 (:actual-type :pointer))
13
14 (define-parse-method pobject (&optional class)
15 (make-instance 'cffi-pobject :class class))
16
17 (defmethod translate-from-foreign (ptr (cffi-pobject cffi-pobject))
18 "The first int at GObject instance is its type pointer, take it and
19 make up lisp object"
20 (declare (type foreign-pointer ptr))
21 (unless (null-pointer-p ptr)
22 ; (format t "pobject: ~a~%" ptr)
23 (let ((class (or (object-class cffi-pobject)
24 (g-type->lisp (g-type-from-instance ptr)))))
25 ; (format t "gtype: ~a :: ~a~%" (g-type-from-instance ptr) class)
26
27 (find-object ptr class))))
28
29 ;; register as object type for g-list
30 (defmethod g-lib-cffi::object-type ((type-name (eql 'pobject))) t)
31
32 ;;; Class STORAGE
33
34 (defclass storage (object)
35 ((data :accessor data :initarg :data)
36 (volatile :initform nil :accessor volatile))
37 (:documentation "A storage for any data for callbacks.
38 On make-instance it allocates one byte on heap and associates itself
39 with the address of that byte."))
40
41 ;; register as object type for g-list
42 (defmethod g-lib-cffi::object-type ((type-name (eql 'pdata))) t)
43
44 (defmethod gconstructor ((storage storage) &key &allow-other-keys)
45 (foreign-alloc :char))
46
47 (defcallback free-storage :void ((data :pointer) (closure :pointer))
48 (declare (ignore closure))
49 (unless (null-pointer-p data)
50 (setf (pointer (find-object data)) (null-pointer))
51 (remhash (pointer-address data) *objects*)
52 (foreign-free data)))
53
54
55 (define-foreign-type cffi-pdata (cffi-pobject freeable-base)
56 ((free-to-foreign :initform nil))
57 (:actual-type :pointer)
58 (:simple-parser pdata)
59 (:documentation "PDATA lets send any data via a c-pointer. C-pointer used as
60 an id for the data. NB! Don't forget to free pointers after use."))
61
62 (defmethod free-ptr ((type (eql 'cffi-pdata)) object)
63 ; it's not typo:
64 ;we free object, not pointer
65 (free object))
66
67 (defmethod translate-from-foreign (ptr (type cffi-pdata))
68 "Returns saved data."
69 (let ((obj (find-object ptr)))
70 (if obj
71 (typecase obj
72 (storage (prog1 (data obj) (free-returned-if-needed type obj)))
73 (t obj))
74 ptr)))
75
76 (defmethod translate-to-foreign ((any-data object) (type cffi-pdata))
77 (pointer any-data))
78
79 (defmethod translate-to-foreign ((any-data null) (type cffi-pdata))
80 (null-pointer))
81
82 (defmethod translate-to-foreign (any-data (type cffi-pdata))
83 (if (pointerp any-data)
84 any-data
85 (let ((obj (make-instance 'storage :data any-data)))
86 (values (pointer obj) obj))))
87
88 (defmethod free-translated-object (ptr (type cffi-pdata) param)
89 (when param
90 (free-sent-if-needed type param param)))
91
92 (defctype g-list-object (g-list :elt pobject))
93
94
95 (defcfun g-type-interface-peek-parent pobject (iface pobject))
96
97 (defcfun g-type-class-peek-parent pobject (class pobject))

  ViewVC Help
Powered by ViewVC 1.1.5