glib/gobject.boxed.lisp

   1 (in-package :gobject)
   2
   3 (define-foreign-type g-boxed-foreign-type ()
   4   ((info :initarg :info
   5          :accessor g-boxed-foreign-info
   6          :initform (error "info must be specified")))
   7   (:actual-type :pointer))
   8
   9 (eval-when (:compile-toplevel :load-toplevel :execute)
  10   (defstruct g-boxed-info
  11     name
  12     g-type))
  13
  14 (eval-when (:compile-toplevel :load-toplevel :execute)
  15   (defun get-g-boxed-foreign-info (name)
  16     (get name 'g-boxed-foreign-info)))
  17
  18 (defvar *g-type-name->g-boxed-foreign-info* (make-hash-table :test 'equal))
  19
  20 (defun get-g-boxed-foreign-info-for-gtype (g-type-designator)
  21   (or (gethash (g-type-string g-type-designator) *g-type-name->g-boxed-foreign-info*)
  22       (error "Unknown GBoxed type '~A'" (g-type-string g-type-designator))))
  23
  24 (define-parse-method g-boxed-foreign (name)
  25   (let ((info (get-g-boxed-foreign-info name)))
  26     (assert info nil "Unknown foreign GBoxed type ~A" name)
  27     (make-instance 'g-boxed-foreign-type :info info)))
  28
  29 (defgeneric boxed-proxy-to-native (type-info proxy))
  30
  31 (defgeneric boxed-read-values-from-native (type-info proxy native))
  32
  33 (defgeneric boxed-native-to-proxy (type-info native))
  34
  35 (defgeneric boxed-write-values-to-native-and-free (type-info proxy native))
  36
  37 (defmethod translate-to-foreign (proxy (type g-boxed-foreign-type))
  38   (if proxy
  39       (let ((boxed-type-info (g-boxed-foreign-info type)))
  40         (values (boxed-proxy-to-native boxed-type-info proxy) proxy))
  41       (null-pointer)))
  42
  43 (defmethod free-translated-object (native-structure (type g-boxed-foreign-type) proxy)
  44   (when proxy
  45     (let ((boxed-type-info (g-boxed-foreign-info type)))
  46       (boxed-read-values-from-native boxed-type-info proxy native-structure)
  47       (g-boxed-free (g-boxed-info-g-type boxed-type-info) native-structure))))
  48
  49 (defmethod translate-from-foreign (native-structure (type g-boxed-foreign-type))
  50   (unless (null-pointer-p native-structure)
  51     (let ((info (g-boxed-foreign-info type)))
  52       (boxed-native-to-proxy info native-structure))))
  53
  54 (defmethod cleanup-translated-object-for-callback ((type g-boxed-foreign-type) proxy native-structure)
  55   (unless (null-pointer-p native-structure)
  56     (let ((info (g-boxed-foreign-info type)))
  57       (boxed-write-values-to-native-and-free info proxy native-structure))))
  58
  59 (defmethod has-callback-cleanup ((type g-boxed-foreign-type))
  60   t)
  61
  62 (eval-when (:load-toplevel :compile-toplevel :execute)
  63   (defstruct (g-boxed-cstruct-wrapper-info (:include g-boxed-info))
  64     cstruct
  65     slots))
  66
  67 (defmacro define-g-boxed-cstruct (name g-type-name &body slots)
  68   `(progn
  69      (defstruct ,name
  70        ,@(iter (for (name type &key initarg) in slots)
  71                (collect (list name initarg))))
  72      (defcstruct ,(generated-cstruct-name name)
  73        ,@(iter (for (name type &key initarg) in slots)
  74                (collect `(,name ,type))))
  75      (eval-when (:compile-toplevel :load-toplevel :execute)
  76        (setf (get ',name 'g-boxed-foreign-info)
  77              (make-g-boxed-cstruct-wrapper-info :name ',name
  78                                                 :g-type ,g-type-name
  79                                                 :cstruct ',(generated-cstruct-name name)
  80                                                 :slots ',(iter (for (name type &key initarg) in slots)
  81                                                                (collect name)))
  82              (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
  83              (get ',name 'g-boxed-foreign-info)))))
  84
  85 (defmethod boxed-proxy-to-native ((type g-boxed-cstruct-wrapper-info) proxy)
  86   (let* ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type))
  87          (native-structure (foreign-alloc native-structure-type)))
  88     (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
  89           (setf (foreign-slot-value native-structure native-structure-type slot)
  90                 (slot-value proxy slot)))
  91     (prog1 (g-boxed-copy (g-boxed-info-g-type type) native-structure)
  92       (foreign-free native-structure))))
  93
  94 (defmethod boxed-native-to-proxy ((type g-boxed-cstruct-wrapper-info) native-structure)
  95   (let* ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type))
  96          (proxy-structure-type (g-boxed-info-name type))
  97          (proxy (make-instance proxy-structure-type)))
  98     (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
  99           (setf (slot-value proxy slot)
 100                 (foreign-slot-value native-structure native-structure-type slot)))
 101     proxy))
 102
 103 (defmethod boxed-read-values-from-native ((type g-boxed-cstruct-wrapper-info) proxy native-structure)
 104   (let ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type)))
 105     (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
 106           (setf (slot-value proxy slot)
 107                 (foreign-slot-value native-structure native-structure-type slot)))))
 108
 109 (defmethod boxed-write-values-to-native-and-free ((type g-boxed-cstruct-wrapper-info) proxy native-structure)
 110   (let ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type)))
 111     (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
 112           (setf (foreign-slot-value native-structure native-structure-type slot)
 113                 (slot-value proxy slot)))))
 114
 115 (eval-when (:compile-toplevel :load-toplevel :execute)
 116   (defstruct (g-boxed-opaque-wrapper-info (:include g-boxed-info))
 117     alloc free))
 118
 119 (defclass g-boxed-opaque ()
 120   ((pointer :initarg :pointer
 121             :initform nil
 122             :accessor g-boxed-opaque-pointer)))
 123
 124 (defmethod boxed-proxy-to-native ((type g-boxed-opaque-wrapper-info) proxy)
 125   (g-boxed-copy (g-boxed-info-g-type type) (g-boxed-opaque-pointer proxy)))
 126
 127 (defun make-boxed-free-finalizer (g-type pointer)
 128   (lambda () (g-boxed-free g-type pointer)))
 129
 130 (defmethod boxed-native-to-proxy ((type g-boxed-opaque-wrapper-info) native)
 131   (let* ((g-type (g-boxed-info-g-type type))
 132          (proxy (make-instance (g-boxed-info-name type) :pointer native)))
 133     (tg:finalize proxy (make-boxed-free-finalizer g-type native))))
 134
 135 (defmethod boxed-read-values-from-native ((type g-boxed-opaque-wrapper-info) proxy native)
 136   (g-boxed-free (g-boxed-info-g-type type) (g-boxed-opaque-pointer proxy))
 137   (tg:cancel-finalization proxy)
 138   (tg:finalize proxy (make-boxed-free-finalizer (g-boxed-info-g-type type) native)))
 139
 140 (defmethod boxed-write-values-to-native-and-free ((type g-boxed-opaque-wrapper-info) proxy native)
 141   (declare (ignore type native))
 142   (tg:cancel-finalization proxy))
 143
 144 (defmacro define-g-boxed-opaque (name g-type-name &key
 145                                  (alloc (error "Alloc must be specified")))
 146   (let ((native-copy (gensym "NATIVE-COPY-"))
 147         (instance (gensym "INSTANCE-"))
 148         (finalizer (gensym "FINALIZER-")))
 149     `(progn (defclass ,name (g-boxed-opaque) ())
 150             (defmethod initialize-instance :after ((,instance ,name) &key &allow-other-keys)
 151               (unless (g-boxed-opaque-pointer ,instance)
 152                 (let ((,native-copy ,alloc))
 153                   (flet ((,finalizer () (g-boxed-free ,g-type-name ,native-copy)))
 154                     (setf (g-boxed-opaque-pointer ,instance) ,native-copy)
 155                     (finalize ,instance #',finalizer)))))
 156             (eval-when (:compile-toplevel :load-toplevel :execute)
 157               (setf (get ',name 'g-boxed-foreign-info)
 158                     (make-g-boxed-opaque-wrapper-info :name ',name
 159                                                       :g-type ,g-type-name)
 160                     (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
 161                     (get ',name 'g-boxed-foreign-info))))))
 162
 163 (defstruct var-structure
 164   name
 165   parent
 166   slots
 167   discriminator-slot
 168   variants)
 169
 170 (defstruct var-structure-variant
 171   discriminating-values
 172   structure)
 173
 174 (defstruct var-structure-slot
 175   name
 176   type
 177   initform
 178   count)
 179
 180 (defmethod make-load-form ((object var-structure) &optional env)
 181   (make-load-form-saving-slots object :environment env))
 182
 183 (defmethod make-load-form ((object var-structure-slot) &optional env)
 184   (make-load-form-saving-slots object :environment env))
 185
 186 (defmethod make-load-form ((object var-structure-variant) &optional env)
 187   (make-load-form-saving-slots object :environment env))
 188
 189 (defun var-struct-all-slots (struct)
 190   (when struct
 191     (append (var-struct-all-slots (var-structure-parent struct))
 192             (var-structure-slots struct))))
 193
 194 (defun all-structures (structure)
 195   (append (iter (for variant in (var-structure-variants structure))
 196                 (appending (all-structures (var-structure-variant-structure variant))))
 197           (list structure)))
 198
 199 (defun parse-variant-structure-definition (name slots &optional parent)
 200   (iter (with result = (make-var-structure :name name
 201                                            :parent parent
 202                                            :slots nil
 203                                            :discriminator-slot nil
 204                                            :variants nil))
 205         (for slot in slots)
 206         (if (eq :variant (first slot))
 207             (progn
 208               (when (var-structure-discriminator-slot result)
 209                 (error "Structure has more than one discriminator slot"))
 210               (setf (var-structure-discriminator-slot result) (second slot)
 211                     (var-structure-variants result) (parse-variants result (nthcdr 2 slot))))
 212             (push (parse-slot slot) (var-structure-slots result)))
 213         (finally (setf (var-structure-slots result)
 214                        (reverse (var-structure-slots result)))
 215                  (return result))))
 216
 217 (defun parse-slot (slot)
 218   (destructuring-bind (name type &key count initform) slot
 219     (make-var-structure-slot :name name :type type :count count :initform initform)))
 220
 221 (defun ensure-list (thing)
 222   (if (listp thing)
 223       thing
 224       (list thing)))
 225
 226 (defun parse-variants (parent variants)
 227   (iter (for var-descr in variants)
 228         (for (options variant-name . slots) in variants)
 229         (for variant =
 230              (make-var-structure-variant
 231               :discriminating-values (ensure-list options)
 232               :structure (parse-variant-structure-definition variant-name slots parent)))
 233         (collect variant)))
 234
 235 (defun generated-cstruct-name (symbol)
 236   (or (get symbol 'generated-cstruct-name)
 237       (setf (get symbol 'generated-cstruct-name) (gensym (format nil "GEN-~A-CSTRUCT-" (symbol-name symbol))))))
 238
 239 (defun generated-cunion-name (symbol)
 240   (or (get symbol 'generated-cunion-name)
 241       (setf (get symbol 'generated-cunion-name) (gensym (format nil "GEN-~A-CUNION-" (symbol-name symbol))))))
 242
 243 (defun generate-cstruct-1 (struct)
 244   `(defcstruct ,(generated-cstruct-name (var-structure-name struct))
 245      ,@(iter (for slot in (var-struct-all-slots struct))
 246              (collect `(,(var-structure-slot-name slot) ,(var-structure-slot-type slot)
 247                          ,@(when (var-structure-slot-count slot)
 248                                  (list `(:count ,(var-structure-slot-count slot)))))))))
 249
 250 (defun generate-c-structures (structure)
 251   (iter (for str in (all-structures structure))
 252         (collect (generate-cstruct-1 str))))
 253
 254 (defun generate-union-1 (struct)
 255   `(defcunion ,(generated-cunion-name (var-structure-name struct))
 256      ,@(iter (for variant in (all-structures struct))
 257              (unless (eq struct variant)
 258                (collect `(,(var-structure-name variant)
 259                            ,(generated-cunion-name (var-structure-name variant))))))))
 260
 261 (defun generate-unions (struct)
 262   (iter (for str in (all-structures struct))
 263         (collect (generate-union-1 str))))
 264
 265 (defun generate-structure-1 (str)
 266   `(defstruct ,(if (var-structure-parent str)
 267                    `(,(var-structure-name str) (:include ,(var-structure-name (var-structure-parent str))
 268                                                          (,(var-structure-discriminator-slot (var-structure-parent str))
 269                                                            ,(first (var-structure-variant-discriminating-values
 270                                                                     (find str
 271                                                                           (var-structure-variants
 272                                                                            (var-structure-parent str))
 273                                                                           :key #'var-structure-variant-structure))))))
 274                    `,(var-structure-name str))
 275      ,@(iter (for slot in (var-structure-slots str))
 276              (collect `(,(var-structure-slot-name slot)
 277                          ,(var-structure-slot-initform slot))))))
 278
 279 (defun generate-structures (str)
 280   (iter (for variant in (reverse (all-structures str)))
 281         (collect (generate-structure-1 variant))))
 282
 283 (defun generate-native-type-decision-procedure-1 (str proxy-var)
 284   (if (null (var-structure-discriminator-slot str))
 285       `(values ',(generated-cstruct-name (var-structure-name str))
 286                ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)))
 287       `(typecase ,proxy-var
 288          ,@(iter (for variant in (var-structure-variants str))
 289                  (for v-str = (var-structure-variant-structure variant))
 290                  (collect `(,(var-structure-name v-str)
 291                              ,(generate-native-type-decision-procedure-1 v-str proxy-var))))
 292          (,(var-structure-name str)
 293           (values ',(generated-cstruct-name (var-structure-name str))
 294                   ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)))))))
 295
 296 (defun generate-proxy-type-decision-procedure-1 (str native-var)
 297   (if (null (var-structure-discriminator-slot str))
 298       `(values ',(var-structure-name str)
 299                ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))
 300                ',(generated-cstruct-name (var-structure-name str)))
 301       `(case (foreign-slot-value ,native-var
 302                                  ',(generated-cstruct-name (var-structure-name str))
 303                                  ',(var-structure-discriminator-slot str))
 304          ,@(iter (for variant in (var-structure-variants str))
 305                  (for v-str = (var-structure-variant-structure variant))
 306                  (collect `(,(var-structure-variant-discriminating-values variant)
 307                              ,(generate-proxy-type-decision-procedure-1
 308                                v-str
 309                                native-var))))
 310          (t (values ',(var-structure-name str)
 311                     ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))
 312                     ',(generated-cstruct-name (var-structure-name str)))))))
 313
 314 (defun generate-proxy-type-decision-procedure (str)
 315   (let ((native (gensym "NATIVE-")))
 316     `(lambda (,native)
 317        ,(generate-proxy-type-decision-procedure-1 str native))))
 318
 319 (defun generate-native-type-decision-procedure (str)
 320   (let ((proxy (gensym "PROXY-")))
 321     `(lambda (,proxy)
 322        ,(generate-native-type-decision-procedure-1 str proxy))))
 323
 324 (defun compile-proxy-type-decision-procedure (str)
 325   (compile nil (generate-proxy-type-decision-procedure str)))
 326
 327 (defun compile-native-type-decision-procedure (str)
 328   (compile nil (generate-native-type-decision-procedure str)))
 329
 330 (defstruct (g-boxed-variant-cstruct-info (:include g-boxed-info))
 331   root
 332   native-type-decision-procedure
 333   proxy-type-decision-procedure)
 334
 335 (defmethod make-load-form ((object g-boxed-variant-cstruct-info) &optional env)
 336   (make-load-form-saving-slots object :environment env))
 337
 338 (defmacro define-g-boxed-variant-cstruct (name g-type-name &body slots)
 339   (let* ((structure (parse-variant-structure-definition name slots)))
 340     `(progn ,@(generate-c-structures structure)
 341             ,@(generate-unions structure)
 342             ,@(generate-structures structure)
 343             (eval-when (:compile-toplevel :load-toplevel :execute)
 344               (setf (get ',name 'g-boxed-foreign-info)
 345                     (make-g-boxed-variant-cstruct-info :name ',name
 346                                                        :g-type ,g-type-name
 347                                                        :root ,structure
 348                                                        :native-type-decision-procedure
 349                                                        ,(generate-native-type-decision-procedure structure)
 350                                                        :proxy-type-decision-procedure
 351                                                        ,(generate-proxy-type-decision-procedure structure))
 352                     (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
 353                     (get ',name 'g-boxed-foreign-info))))))
 354
 355 (defun decide-native-type (info proxy)
 356   (funcall (g-boxed-variant-cstruct-info-native-type-decision-procedure info) proxy))
 357
 358 (defmethod boxed-proxy-to-native ((type g-boxed-variant-cstruct-info) proxy)
 359   (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy)
 360     (let ((native-structure (foreign-alloc
 361                              (generated-cstruct-name
 362                               (var-structure-name
 363                                (g-boxed-variant-cstruct-info-root type))))))
 364       (iter (for slot in slots)
 365             (setf (foreign-slot-value native-structure actual-cstruct slot)
 366                   (slot-value proxy slot)))
 367       (prog1 (g-boxed-copy (g-boxed-info-g-type type) native-structure)
 368         (foreign-free native-structure)))))
 369
 370 (defun decide-proxy-type (info native-structure)
 371   (funcall (g-boxed-variant-cstruct-info-proxy-type-decision-procedure info) native-structure))
 372
 373 (defmethod boxed-write-values-to-native-and-free ((type g-boxed-variant-cstruct-info) proxy native-ptr)
 374   (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native-ptr)
 375     (unless (eq (type-of proxy) actual-struct)
 376       (restart-case
 377           (error "Expected type of boxed variant structure ~A and actual type ~A do not match"
 378                  (type-of proxy) actual-struct)
 379         (skip-parsing-values () (return-from boxed-write-values-to-native-and-free))))
 380     (iter (for slot in slots)
 381           (setf (slot-value proxy slot)
 382                 (foreign-slot-value native-ptr actual-cstruct slot)))))
 383
 384 (defmethod boxed-native-to-proxy ((type g-boxed-variant-cstruct-info) native-ptr)
 385   (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native-ptr)
 386     (let ((proxy (make-instance actual-struct)))
 387       (iter (for slot in slots)
 388             (setf (slot-value proxy slot)
 389                   (foreign-slot-value native-ptr actual-cstruct slot)))
 390       proxy)))
 391
 392 (defgeneric boxed-native-to-proxy-needs-copy-for-gvalue-get (type))
 393
 394 (defmethod boxed-native-to-proxy-needs-copy-for-gvalue-get ((type g-boxed-cstruct-wrapper-info))
 395   nil)
 396
 397 (defmethod boxed-native-to-proxy-needs-copy-for-gvalue-get ((type g-boxed-variant-cstruct-info))
 398   nil)
 399
 400 (defmethod boxed-native-to-proxy-needs-copy-for-gvalue-get ((type g-boxed-opaque-wrapper-info))
 401   t)
 402
 403 (defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) parse-kind)
 404   (declare (ignore parse-kind))
 405   (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
 406       (convert-from-foreign (g-value-get-boxed gvalue-ptr) '(glib:gstrv :free-from-foreign nil))
 407       (let* ((boxed-type (get-g-boxed-foreign-info-for-gtype type-numeric))
 408              (native (if (boxed-native-to-proxy-needs-copy-for-gvalue-get boxed-type)
 409                          (g-boxed-copy type-numeric (g-value-get-boxed gvalue-ptr))
 410                          (g-value-get-boxed gvalue-ptr))))
 411         (boxed-native-to-proxy boxed-type native))))
 412
 413 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) value)
 414   (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
 415       (g-value-set-boxed gvalue-ptr (convert-to-foreign value '(glib:gstrv :free-from-foreign nil)))
 416       (let* ((boxed-type (get-g-boxed-foreign-info-for-gtype type-numeric))
 417              (native (boxed-proxy-to-native boxed-type value)))
 418         (g-value-take-boxed gvalue-ptr native))))