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