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