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 (defmethod boxed-native-to-proxy ((type g-boxed-opaque-wrapper-info) native)
 128   (let ((g-type (g-boxed-info-g-type type)))
 129     (flet ((finalizer () (g-boxed-free g-type native)))
 130       (let ((proxy (make-instance (g-boxed-info-name type) :pointer native)))
 131         (tg:finalize proxy #'finalizer)))))
 132
 133 (defmethod boxed-read-values-from-native ((type g-boxed-opaque-wrapper-info) proxy native)
 134   (declare (ignore type proxy native)))
 135
 136 (defmethod boxed-write-values-to-native-and-free ((type g-boxed-opaque-wrapper-info) proxy native)
 137   (declare (ignore type native))
 138   (tg:cancel-finalization proxy))
 139
 140 (defmacro define-g-boxed-opaque (name g-type-name &key
 141                                  (alloc (error "Alloc must be specified")))
 142   (let ((native-copy (gensym "NATIVE-COPY-"))
 143         (instance (gensym "INSTANCE-"))
 144         (finalizer (gensym "FINALIZER-")))
 145     `(progn (defclass ,name (g-boxed-opaque) ())
 146             (defmethod initialize-instance :after ((,instance ,name) &key &allow-other-keys)
 147               (unless (g-boxed-opaque-pointer ,instance)
 148                 (let ((,native-copy ,alloc))
 149                   (flet ((,finalizer () (g-boxed-free ,g-type-name ,native-copy)))
 150                     (setf (g-boxed-opaque-pointer ,instance) ,native-copy)
 151                     (finalize ,instance #',finalizer)))))
 152             (eval-when (:compile-toplevel :load-toplevel :execute)
 153               (setf (get ',name 'g-boxed-foreign-info)
 154                     (make-g-boxed-opaque-wrapper-info :name ',name
 155                                                       :g-type ,g-type-name)
 156                     (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
 157                     (get ',name 'g-boxed-foreign-info))))))
 158
 159 (defstruct var-structure
 160   name
 161   parent
 162   slots
 163   discriminator-slot
 164   variants)
 165
 166 (defstruct var-structure-variant
 167   discriminating-values
 168   structure)
 169
 170 (defstruct var-structure-slot
 171   name
 172   type
 173   initform
 174   count)
 175
 176 (defmethod make-load-form ((object var-structure) &optional env)
 177   (make-load-form-saving-slots object :environment env))
 178
 179 (defmethod make-load-form ((object var-structure-slot) &optional env)
 180   (make-load-form-saving-slots object :environment env))
 181
 182 (defmethod make-load-form ((object var-structure-variant) &optional env)
 183   (make-load-form-saving-slots object :environment env))
 184
 185 (defun var-struct-all-slots (struct)
 186   (when struct
 187     (append (var-struct-all-slots (var-structure-parent struct))
 188             (var-structure-slots struct))))
 189
 190 (defun all-structures (structure)
 191   (append (iter (for variant in (var-structure-variants structure))
 192                 (appending (all-structures (var-structure-variant-structure variant))))
 193           (list structure)))
 194
 195 (defun parse-variant-structure-definition (name slots &optional parent)
 196   (iter (with result = (make-var-structure :name name
 197                                            :parent parent
 198                                            :slots nil
 199                                            :discriminator-slot nil
 200                                            :variants nil))
 201         (for slot in slots)
 202         (if (eq :variant (first slot))
 203             (progn
 204               (when (var-structure-discriminator-slot result)
 205                 (error "Structure has more than one discriminator slot"))
 206               (setf (var-structure-discriminator-slot result) (second slot)
 207                     (var-structure-variants result) (parse-variants result (nthcdr 2 slot))))
 208             (push (parse-slot slot) (var-structure-slots result)))
 209         (finally (setf (var-structure-slots result)
 210                        (reverse (var-structure-slots result)))
 211                  (return result))))
 212
 213 (defun parse-slot (slot)
 214   (destructuring-bind (name type &key count initform) slot
 215     (make-var-structure-slot :name name :type type :count count :initform initform)))
 216
 217 (defun ensure-list (thing)
 218   (if (listp thing)
 219       thing
 220       (list thing)))
 221
 222 (defun parse-variants (parent variants)
 223   (iter (for var-descr in variants)
 224         (for (options variant-name . slots) in variants)
 225         (for variant =
 226              (make-var-structure-variant
 227               :discriminating-values (ensure-list options)
 228               :structure (parse-variant-structure-definition variant-name slots parent)))
 229         (collect variant)))
 230
 231 (defun generated-cstruct-name (symbol)
 232   (or (get symbol 'generated-cstruct-name)
 233       (setf (get symbol 'generated-cstruct-name) (gensym (format nil "GEN-~A-CSTRUCT-" (symbol-name symbol))))))
 234
 235 (defun generated-cunion-name (symbol)
 236   (or (get symbol 'generated-cunion-name)
 237       (setf (get symbol 'generated-cunion-name) (gensym (format nil "GEN-~A-CUNION-" (symbol-name symbol))))))
 238
 239 (defun generate-cstruct-1 (struct)
 240   `(defcstruct ,(generated-cstruct-name (var-structure-name struct))
 241      ,@(iter (for slot in (var-struct-all-slots struct))
 242              (collect `(,(var-structure-slot-name slot) ,(var-structure-slot-type slot)
 243                          ,@(when (var-structure-slot-count slot)
 244                                  (list `(:count ,(var-structure-slot-count slot)))))))))
 245
 246 (defun generate-c-structures (structure)
 247   (iter (for str in (all-structures structure))
 248         (collect (generate-cstruct-1 str))))
 249
 250 (defun generate-union-1 (struct)
 251   `(defcunion ,(generated-cunion-name (var-structure-name struct))
 252      ,@(iter (for variant in (all-structures struct))
 253              (unless (eq struct variant)
 254                (collect `(,(var-structure-name variant)
 255                            ,(generated-cunion-name (var-structure-name variant))))))))
 256
 257 (defun generate-unions (struct)
 258   (iter (for str in (all-structures struct))
 259         (collect (generate-union-1 str))))
 260
 261 (defun generate-structure-1 (str)
 262   `(defstruct ,(if (var-structure-parent str)
 263                    `(,(var-structure-name str) (:include ,(var-structure-name (var-structure-parent str))
 264                                                          (,(var-structure-discriminator-slot (var-structure-parent str))
 265                                                            ,(first (var-structure-variant-discriminating-values
 266                                                                     (find str
 267                                                                           (var-structure-variants
 268                                                                            (var-structure-parent str))
 269                                                                           :key #'var-structure-variant-structure))))))
 270                    `,(var-structure-name str))
 271      ,@(iter (for slot in (var-structure-slots str))
 272              (collect `(,(var-structure-slot-name slot)
 273                          ,(var-structure-slot-initform slot))))))
 274
 275 (defun generate-structures (str)
 276   (iter (for variant in (reverse (all-structures str)))
 277         (collect (generate-structure-1 variant))))
 278
 279 (defun generate-native-type-decision-procedure-1 (str proxy-var)
 280   (if (null (var-structure-discriminator-slot str))
 281       `(values ',(generated-cstruct-name (var-structure-name str))
 282                ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)))
 283       `(typecase ,proxy-var
 284          ,@(iter (for variant in (var-structure-variants str))
 285                  (for v-str = (var-structure-variant-structure variant))
 286                  (collect `(,(var-structure-name v-str)
 287                              ,(generate-native-type-decision-procedure-1 v-str proxy-var))))
 288          (,(var-structure-name str)
 289           (values ',(generated-cstruct-name (var-structure-name str))
 290                   ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)))))))
 291
 292 (defun generate-proxy-type-decision-procedure-1 (str native-var)
 293   (if (null (var-structure-discriminator-slot str))
 294       `(values ',(var-structure-name str)
 295                ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))
 296                ',(generated-cstruct-name (var-structure-name str)))
 297       `(case (foreign-slot-value ,native-var
 298                                  ',(generated-cstruct-name (var-structure-name str))
 299                                  ',(var-structure-discriminator-slot str))
 300          ,@(iter (for variant in (var-structure-variants str))
 301                  (for v-str = (var-structure-variant-structure variant))
 302                  (collect `(,(var-structure-variant-discriminating-values variant)
 303                              ,(generate-proxy-type-decision-procedure-1
 304                                v-str
 305                                native-var))))
 306          (t (values ',(var-structure-name str)
 307                     ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))
 308                     ',(generated-cstruct-name (var-structure-name str)))))))
 309
 310 (defun generate-proxy-type-decision-procedure (str)
 311   (let ((native (gensym "NATIVE-")))
 312     `(lambda (,native)
 313        ,(generate-proxy-type-decision-procedure-1 str native))))
 314
 315 (defun generate-native-type-decision-procedure (str)
 316   (let ((proxy (gensym "PROXY-")))
 317     `(lambda (,proxy)
 318        ,(generate-native-type-decision-procedure-1 str proxy))))
 319
 320 (defun compile-proxy-type-decision-procedure (str)
 321   (compile nil (generate-proxy-type-decision-procedure str)))
 322
 323 (defun compile-native-type-decision-procedure (str)
 324   (compile nil (generate-native-type-decision-procedure str)))
 325
 326 (defstruct (g-boxed-variant-cstruct-info (:include g-boxed-info))
 327   root
 328   native-type-decision-procedure
 329   proxy-type-decision-procedure)
 330
 331 (defmethod make-load-form ((object g-boxed-variant-cstruct-info) &optional env)
 332   (make-load-form-saving-slots object :environment env))
 333
 334 (defmacro define-g-boxed-variant-cstruct (name g-type-name &body slots)
 335   (let* ((structure (parse-variant-structure-definition name slots)))
 336     `(progn ,@(generate-c-structures structure)
 337             ,@(generate-unions structure)
 338             ,@(generate-structures structure)
 339             (eval-when (:compile-toplevel :load-toplevel :execute)
 340               (setf (get ',name 'g-boxed-foreign-info)
 341                     (make-g-boxed-variant-cstruct-info :name ',name
 342                                                        :g-type ,g-type-name
 343                                                        :root ,structure
 344                                                        :native-type-decision-procedure
 345                                                        ,(generate-native-type-decision-procedure structure)
 346                                                        :proxy-type-decision-procedure
 347                                                        ,(generate-proxy-type-decision-procedure structure))
 348                     (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
 349                     (get ',name 'g-boxed-foreign-info))))))
 350
 351 (defun decide-native-type (info proxy)
 352   (funcall (g-boxed-variant-cstruct-info-native-type-decision-procedure info) proxy))
 353
 354 (defmethod boxed-proxy-to-native ((type g-boxed-variant-cstruct-info) proxy)
 355   (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy)
 356     (let ((native-structure (foreign-alloc
 357                              (generated-cstruct-name
 358                               (var-structure-name
 359                                (g-boxed-variant-cstruct-info-root type))))))
 360       (iter (for slot in slots)
 361             (setf (foreign-slot-value native-structure actual-cstruct slot)
 362                   (slot-value proxy slot)))
 363       (prog1 (g-boxed-copy (g-boxed-info-g-type type) native-structure)
 364         (foreign-free native-structure)))))
 365
 366 (defun decide-proxy-type (info native-structure)
 367   (funcall (g-boxed-variant-cstruct-info-proxy-type-decision-procedure info) native-structure))
 368
 369 (defmethod boxed-write-values-to-native-and-free ((type g-boxed-variant-cstruct-info) proxy native-ptr)
 370   (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native-ptr)
 371     (unless (eq (type-of proxy) actual-struct)
 372       (restart-case
 373           (error "Expected type of boxed variant structure ~A and actual type ~A do not match"
 374                  (type-of proxy) actual-struct)
 375         (skip-parsing-values () (return-from boxed-write-values-to-native-and-free))))
 376     (iter (for slot in slots)
 377           (setf (slot-value proxy slot)
 378                 (foreign-slot-value native-ptr actual-cstruct slot)))))
 379
 380 (defmethod boxed-native-to-proxy ((type g-boxed-variant-cstruct-info) native-ptr)
 381   (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native-ptr)
 382     (let ((proxy (make-instance actual-struct)))
 383       (iter (for slot in slots)
 384             (setf (slot-value proxy slot)
 385                   (foreign-slot-value native-ptr actual-cstruct slot)))
 386       proxy)))
 387
 388 (defgeneric boxed-native-to-proxy-needs-copy-for-gvalue-get (type))
 389
 390 (defmethod boxed-native-to-proxy-needs-copy-for-gvalue-get ((type g-boxed-cstruct-wrapper-info))
 391   nil)
 392
 393 (defmethod boxed-native-to-proxy-needs-copy-for-gvalue-get ((type g-boxed-variant-cstruct-info))
 394   nil)
 395
 396 (defmethod boxed-native-to-proxy-needs-copy-for-gvalue-get ((type g-boxed-opaque-wrapper-info))
 397   t)
 398
 399 (defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) parse-kind)
 400   (declare (ignore parse-kind))
 401   (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
 402       (convert-from-foreign (g-value-get-boxed gvalue-ptr) '(glib:gstrv :free-from-foreign nil))
 403       (let* ((boxed-type (get-g-boxed-foreign-info-for-gtype type-numeric))
 404              (native (if (boxed-native-to-proxy-needs-copy-for-gvalue-get boxed-type)
 405                          (g-boxed-copy type-numeric (g-value-get-boxed gvalue-ptr))
 406                          (g-value-get-boxed gvalue-ptr))))
 407         (create-proxy-for-native boxed-type native))))
 408
 409 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) value)
 410   (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
 411       (g-value-set-boxed gvalue-ptr (convert-to-foreign value '(glib:gstrv :free-from-foreign nil)))
 412       (let* ((boxed-type (get-g-boxed-foreign-info-for-gtype type-numeric))
 413              (native (boxed-proxy-to-native boxed-type value)))
 414         (g-value-take-boxed gvalue-ptr native))))