gboxed.test.lisp

   1 (in-package :gobject)
   2
   3 #+nil(define-g-boxed-class "GdkRectangle" rectangle ()
   4   (x :int :initform 0)
   5   (y :int :initform 0)
   6   (width :int :initform 0)
   7   (height :int :initform 0))
   8
   9 (define-foreign-type g-boxed-foreign-type ()
  10   ((info :initarg :info
  11          :accessor g-boxed-foreign-info
  12          :initform (error "info must be specified"))
  13    (free-from-foreign :initarg :free-from-foreign
  14                       :initform nil
  15                       :accessor g-boxed-foreign-free-from-foreign)
  16    (free-to-foreign :initarg :free-to-foreign
  17                     :initform nil
  18                     :accessor g-boxed-foreign-free-to-foreign)
  19    (for-callback :initarg :for-callback
  20                  :initform nil
  21                  :accessor g-boxed-foreign-for-callback))
  22   (:actual-type :pointer))
  23
  24 (eval-when (:compile-toplevel :load-toplevel :execute)
  25   (defstruct g-boxed-info
  26     name
  27     g-type))
  28
  29 (eval-when (:compile-toplevel :load-toplevel :execute)
  30  (defun get-g-boxed-foreign-info (name)
  31    (get name 'g-boxed-foreign-info)))
  32
  33 (define-parse-method g-boxed-foreign (name &key free-from-foreign free-to-foreign for-callback)
  34   (let ((info (get-g-boxed-foreign-info name)))
  35     (assert info nil "Unknown foreign GBoxed type ~A" name)
  36     (make-instance 'g-boxed-foreign-type
  37                    :info info
  38                    :free-from-foreign free-from-foreign
  39                    :free-to-foreign free-to-foreign
  40                    :for-callback for-callback)))
  41
  42 (eval-when (:load-toplevel :compile-toplevel :execute)
  43   (defstruct (g-boxed-cstruct-wrapper-info (:include g-boxed-info))
  44     cstruct
  45     slots))
  46
  47 (defmacro define-g-boxed-cstruct (name cstruct-name g-type-name &body slots)
  48   `(progn
  49      (defstruct ,name
  50        ,@(iter (for (name type &key initarg) in slots)
  51                (collect (list name initarg))))
  52      (defcstruct ,cstruct-name
  53        ,@(iter (for (name type &key initarg) in slots)
  54                (collect `(,name ,type))))
  55      (eval-when (:compile-toplevel :load-toplevel :execute)
  56        (setf (get ',name 'g-boxed-foreign-info)
  57              (make-g-boxed-cstruct-wrapper-info :name ',name
  58                                                 :g-type ,g-type-name
  59                                                 :cstruct ',cstruct-name
  60                                                 :slots ',(iter (for (name type &key initarg) in slots)
  61                                                                (collect name)))))))
  62
  63 (define-g-boxed-cstruct gdk-rectangle gdk-rectangle-cstruct "GdkRectangle"
  64   (x :int :initarg 0)
  65   (y :int :initarg 0)
  66   (width :int :initarg 0)
  67   (height :int :initarg 0))
  68
  69 (defgeneric create-temporary-native (type proxy)
  70   (:documentation "Creates a native structure (or passes a pointer to copy contained in PROXY)
  71 that contains the same data that the PROXY contains and returns a pointer to it.
  72
  73 This call is always paired by call to FREE-TEMPORARY-NATIVE and calls may be nested."))
  74
  75 (defgeneric free-temporary-native (type proxy native-ptr)
  76   (:documentation "Frees the native structure that was previously created
  77 by CREATE-TEMPORARY-NATIVE for the same PROXY.
  78
  79 Also reads data from native structure pointer to by NATIVE-PTR
  80 and sets the PROXY to contain the same data.
  81
  82 This call is always paired by call to CREATE-TEMPORARY-NATIVE and calls may be nested."))
  83
  84 (defgeneric create-proxy-for-native (type native-ptr)
  85   (:documentation "Creates a proxy that is initialized by data contained in native
  86 structured pointed to by NATIVE-PTR.
  87
  88 Created proxy should not be linked to NATIVE-PTR and should have
  89 indefinite lifetime (until garbage collector collects it). Specifically,
  90 if proxy need a pointer to native structure, it should make a copy of
  91 a structure.
  92
  93 If proxy requires finalization, finalizers should be added."))
  94
  95 (defgeneric create-reference-proxy (type native-ptr)
  96   (:documentation "Creates a reference proxy for a native structure pointed to by NATIVE-PTR.
  97
  98 Reference proxy's lifetime is bound to duration of a callback. When the
  99 callback returns the reference proxy is declared invalid and operations on it are errors.
 100
 101 This call is always paired by call to FREE-REFERENCE-PROXY and calls will not nest."))
 102
 103 (defgeneric free-reference-proxy (type proxy native-ptr)
 104   (:documentation "Frees a reference proxy PROXY previously created by call to
 105 CREATE-REFERENCE-PROXY. This call should ensure that all changes on PROXY are
 106 reflected in native structure pointed to by NATIVE-PTR.
 107
 108 After a call to FREE-REFERENCE-PROXY, PROXY is declared invalid and using it is an error,
 109 operations on it should signal erros.
 110
 111 This call is always paired by call to CREATE-REFERENCE-PROXY."))
 112
 113 (defmethod create-temporary-native ((type g-boxed-cstruct-wrapper-info) proxy)
 114   (format t "create-temporary-native~%")
 115   (let* ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type))
 116          (native-structure (foreign-alloc native-structure-type)))
 117     (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
 118           (setf (foreign-slot-value native-structure native-structure-type slot)
 119                 (slot-value proxy slot)))
 120     native-structure))
 121
 122 (defmethod free-temporary-native ((type g-boxed-cstruct-wrapper-info) proxy native-structure)
 123   (format t "free-temporary-native~%")
 124   (let ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type)))
 125     (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
 126           (setf (slot-value proxy slot)
 127                 (foreign-slot-value native-structure native-structure-type slot))))
 128   (foreign-free native-structure))
 129
 130 (defmethod create-proxy-for-native ((type g-boxed-cstruct-wrapper-info) native-structure)
 131   (format t "create-proxy-for-native~%")
 132   (let* ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type))
 133          (proxy (make-instance (g-boxed-info-name type))))
 134     (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
 135           (setf (slot-value proxy slot)
 136                 (foreign-slot-value native-structure native-structure-type slot)))
 137     proxy))
 138
 139 (defmethod create-reference-proxy ((type g-boxed-cstruct-wrapper-info) native-structure)
 140   (format t "create-reference-proxy~%")
 141   (create-proxy-for-native type native-structure))
 142
 143 (defmethod free-reference-proxy ((type g-boxed-cstruct-wrapper-info) proxy native-structure)
 144   (format t "free-reference-proxy~%")
 145   (let ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type)))
 146     (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
 147           (setf (foreign-slot-value native-structure native-structure-type slot)
 148                 (slot-value proxy slot)))))
 149
 150 (defmethod translate-to-foreign (proxy (type g-boxed-foreign-type))
 151   (if proxy
 152       (let* ((info (g-boxed-foreign-info type)))
 153         (values (create-temporary-native info proxy) proxy))
 154       (null-pointer)))
 155
 156 (defmethod free-translated-object (native-structure (type g-boxed-foreign-type) proxy)
 157   (when proxy
 158     (free-temporary-native (g-boxed-foreign-info type) proxy native-structure)))
 159
 160 (defmethod translate-from-foreign (native-structure (type g-boxed-foreign-type))
 161   (unless (null-pointer-p native-structure)
 162     (let* ((info (g-boxed-foreign-info type)))
 163       (cond
 164         ((g-boxed-foreign-for-callback type)
 165          (create-reference-proxy info native-structure))
 166         ((or (g-boxed-foreign-free-to-foreign type)
 167              (g-boxed-foreign-free-from-foreign type))
 168          (error "Feature not yet handled"))
 169         (t (create-proxy-for-native info native-structure))))))
 170
 171 (defmethod cleanup-translated-object-for-callback ((type g-boxed-foreign-type) proxy native-structure)
 172   (unless (null-pointer-p native-structure)
 173     (free-reference-proxy (g-boxed-foreign-info type) proxy native-structure)))
 174
 175 (defmethod has-callback-cleanup ((type g-boxed-foreign-type))
 176   t)
 177
 178 (defcallback incf-rectangle :void ((rectangle (g-boxed-foreign gdk-rectangle :for-callback t))
 179                                    (delta :int))
 180   (incf (gdk-rectangle-x rectangle) delta)
 181   (incf (gdk-rectangle-y rectangle) delta)
 182   (incf (gdk-rectangle-width rectangle) delta)
 183   (incf (gdk-rectangle-height rectangle) delta)
 184   (format t "~A~%" rectangle))
 185
 186 (defun do-incf-rect (r &optional (delta 1))
 187   (foreign-funcall-pointer (callback incf-rectangle) ()
 188                            (g-boxed-foreign gdk-rectangle) r
 189                            :int delta
 190                            :void)
 191   r)
 192
 193 (eval-when (:compile-toplevel :load-toplevel :execute)
 194   (defstruct (g-boxed-opaque-wrapper-info (:include g-boxed-info))
 195     alloc free))
 196
 197 (defclass g-boxed-opaque ()
 198   ((pointer :initarg :pointer
 199             :initform nil
 200             :accessor g-boxed-opaque-pointer)))
 201
 202 (defmethod create-temporary-native ((type g-boxed-opaque-wrapper-info) proxy)
 203   (declare (ignore type))
 204   (g-boxed-opaque-pointer proxy))
 205
 206 (defmethod free-temporary-native ((type g-boxed-opaque-wrapper-info) proxy native-structure)
 207   (declare (ignore type proxy native-structure)))
 208
 209 (defmethod create-reference-proxy ((type g-boxed-opaque-wrapper-info) native-structure)
 210   (make-instance (g-boxed-info-g-type type) :pointer native-structure))
 211
 212 (defmethod free-reference-proxy ((type g-boxed-opaque-wrapper-info) proxy native-structure)
 213   (declare (ignore type native-structure))
 214   (setf (g-boxed-opaque-pointer proxy) nil))
 215
 216 (defmethod create-proxy-for-native ((type g-boxed-opaque-wrapper-info) native-structure)
 217   (let* ((g-type (g-boxed-info-g-type type))
 218          (native-copy (g-boxed-copy g-type native-structure)))
 219     (flet ((finalizer () (g-boxed-free g-type native-copy)))
 220       (let ((proxy (make-instance (g-boxed-opaque-wrapper-info-g-type type) :pointer native-copy)))
 221         (tg:finalize proxy #'finalizer)
 222         proxy))))
 223
 224 (defmacro define-g-boxed-opaque (name g-type-name &key
 225                                  (alloc (error "Alloc must be specified")))
 226   (let ((native-copy (gensym "NATIVE-COPY-"))
 227         (instance (gensym "INSTANCE-"))
 228         (finalizer (gensym "FINALIZER-")))
 229     `(progn (defclass ,name (g-boxed-opaque) ())
 230             (defmethod initialize-instance :after ((,instance ,name) &key &allow-other-keys)
 231               (unless (g-boxed-opaque-pointer ,instance)
 232                 (let ((,native-copy ,alloc))
 233                   (flet ((,finalizer () (g-boxed-free ,g-type-name ,native-copy)))
 234                     (setf (g-boxed-opaque-pointer ,instance) ,native-copy)
 235                     (finalize ,instance #',finalizer)))))
 236             (eval-when (:compile-toplevel :load-toplevel :execute)
 237               (setf (get ',name 'g-boxed-foreign-info)
 238                     (make-g-boxed-opaque-wrapper-info :name ',name
 239                                                       :g-type ,g-type-name))))))
 240
 241 (define-g-boxed-opaque gtk-tree-path "GtkTreePath"
 242   :alloc (let* ((native-structure (gtk-tree-path-new))
 243                 (native-copy (g-boxed-copy "GtkTreePath" native-structure)))
 244            (gtk-tree-path-free native-structure)
 245            native-copy))
 246
 247 (defcfun gtk-tree-path-new :pointer)
 248
 249 (defcfun gtk-tree-path-free :void
 250   (gtk-tree-path :pointer))
 251
 252 (defcfun gtk-tree-path-copy :pointer
 253   (gtk-tree-path :pointer))
 254
 255 (defcfun (%gtk-tree-path-get-depth "gtk_tree_path_get_depth") :int
 256   (path (g-boxed-foreign gtk-tree-path)))
 257
 258 (defcfun (%gtk-tree-path-get-indices "gtk_tree_path_get_indices") (:pointer :int)
 259   (path (g-boxed-foreign gtk-tree-path)))
 260
 261 (defcfun gtk-tree-path-append-index :void
 262   (path (g-boxed-foreign gtk-tree-path))
 263   (index :int))
 264
 265 (defun tree-path-get-indices (path)
 266   (let ((n (%gtk-tree-path-get-depth path))
 267         (indices (%gtk-tree-path-get-indices path)))
 268     (loop
 269        for i from 0 below n
 270        collect (mem-aref indices :int i))))