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    (return-p :initarg :return-p
   8              :accessor g-boxed-foreign-return-p
   9              :initform nil))
  10   (:actual-type :pointer))
  11
  12 (eval-when (:compile-toplevel :load-toplevel :execute)
  13   (defstruct g-boxed-info
  14     name
  15     g-type))
  16
  17 (eval-when (:compile-toplevel :load-toplevel :execute)
  18   (defun get-g-boxed-foreign-info (name)
  19     (get name 'g-boxed-foreign-info)))
  20
  21 (defvar *g-type-name->g-boxed-foreign-info* (make-hash-table :test 'equal))
  22
  23 (defun get-g-boxed-foreign-info-for-gtype (g-type-designator)
  24   (or (gethash (gtype-name (gtype g-type-designator)) *g-type-name->g-boxed-foreign-info*)
  25       (error "Unknown GBoxed type '~A'" (gtype-name (gtype g-type-designator)))))
  26
  27 (defgeneric make-foreign-type (info &key return-p))
  28
  29 (define-parse-method g-boxed-foreign (name &rest options)
  30   (let ((info (get-g-boxed-foreign-info name)))
  31     (assert info nil "Unknown foreign GBoxed type ~A" name)
  32     (make-foreign-type info :return-p (member :return options))))
  33
  34 (defgeneric boxed-copy-fn (type-info native)
  35   (:method (type-info native)
  36     (g-boxed-copy (g-boxed-info-g-type type-info) native)))
  37
  38 #+nil(defmethod boxed-copy-fn :before (type-info native)
  39   (format t "(boxed-copy-fn ~A ~A)~%" (g-boxed-info-name type-info) native))
  40
  41 (defgeneric boxed-free-fn (type-info native)
  42   (:method (type-info native)
  43     (g-boxed-free (g-boxed-info-g-type type-info) native)))
  44
  45 #+nil(defmethod boxed-free-fn :before (type-info native)
  46   (format t "(boxed-free-fn ~A ~A)~%" (g-boxed-info-name type-info) native))
  47
  48 (defgeneric has-callback-cleanup (foreign-type))
  49 (defgeneric cleanup-translated-object-for-callback (foreign-type converted-object native-object))
  50
  51 (defmethod has-callback-cleanup ((type g-boxed-foreign-type))
  52   t)
  53
  54 (eval-when (:load-toplevel :compile-toplevel :execute)
  55   (defstruct (g-boxed-cstruct-wrapper-info (:include g-boxed-info))
  56     cstruct-description))
  57
  58 (defclass boxed-cstruct-foreign-type (g-boxed-foreign-type) ())
  59
  60 (defstruct cstruct-slot-description
  61   name
  62   type
  63   count
  64   initform
  65   inline-p)
  66
  67 (defstruct (cstruct-inline-slot-description (:include cstruct-slot-description))
  68   boxed-type-name)
  69
  70 (defmethod make-load-form ((object cstruct-slot-description) &optional environment)
  71   (make-load-form-saving-slots object :environment environment))
  72
  73 (defmethod make-load-form ((object cstruct-inline-slot-description) &optional environment)
  74   (make-load-form-saving-slots object :environment environment))
  75
  76 (defstruct cstruct-description
  77   name
  78   slots)
  79
  80 (defmethod make-load-form ((object cstruct-description) &optional environment)
  81   (make-load-form-saving-slots object :environment environment))
  82
  83 (defun parse-cstruct-slot (slot)
  84   (destructuring-bind (name type &key count initform inline) slot
  85     (if inline
  86         (make-cstruct-inline-slot-description :name name :type (generated-cunion-name type)
  87                                        :count count :initform initform :inline-p inline
  88                                        :boxed-type-name type)
  89         (make-cstruct-inline-slot-description :name name :type type
  90                                               :count count :initform initform :inline-p inline))))
  91
  92 (defun parse-cstruct-definition (name slots)
  93   (make-cstruct-description :name name
  94                             :slots (mapcar #'parse-cstruct-slot slots)))
  95
  96 (defmacro define-g-boxed-cstruct (name g-type-name &body slots)
  97   (let ((cstruct-description (parse-cstruct-definition name slots))
  98         (cstruct-name (generated-cstruct-name name))
  99         (cunion-name (generated-cunion-name name)))
 100     `(progn
 101        (defstruct ,name
 102          ,@(iter (for slot in (cstruct-description-slots cstruct-description))
 103                  (for name = (cstruct-slot-description-name slot))
 104                  (for initform = (cstruct-slot-description-initform slot))
 105                  (collect (list name initform))))
 106        (defcstruct ,cstruct-name
 107          ,@(iter (for slot in (cstruct-description-slots cstruct-description))
 108                  (for name = (cstruct-slot-description-name slot))
 109                  (for type = (cstruct-slot-description-type slot))
 110                  (for count = (cstruct-slot-description-count slot))
 111                  (collect `(,name ,type ,@(when count `(:count ,count))))))
 112        (defctype ,cstruct-name (:struct ,cstruct-name))
 113        (defcunion ,cunion-name
 114          (,name ,cstruct-name))
 115        (defctype ,cunion-name (:union ,cunion-name))
 116        (eval-when (:compile-toplevel :load-toplevel :execute)
 117          (setf (get ',name 'g-boxed-foreign-info)
 118                (make-g-boxed-cstruct-wrapper-info :name ',name
 119                                                   :g-type ,g-type-name
 120                                                   :cstruct-description ,cstruct-description)
 121                (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
 122                (get ',name 'g-boxed-foreign-info)
 123                (get ',name 'structure-constructor)
 124                ',(intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name)))))))
 125
 126 (defmethod make-foreign-type ((info g-boxed-cstruct-wrapper-info) &key return-p)
 127   (make-instance 'boxed-cstruct-foreign-type :info info :return-p return-p))
 128
 129 (defun memcpy (target source bytes)
 130   (iter (for i from 0 below bytes)
 131         (setf (mem-aref target :uchar i)
 132               (mem-aref source :uchar i))))
 133
 134 (defmethod boxed-copy-fn ((info g-boxed-cstruct-wrapper-info) native)
 135   (if (g-boxed-info-g-type info)
 136       (g-boxed-copy (g-boxed-info-g-type info) native)
 137       (let ((copy (foreign-alloc (generated-cstruct-name (g-boxed-info-name info)))))
 138         (memcpy copy native (foreign-type-size (generated-cstruct-name (g-boxed-info-name info))))
 139         copy)))
 140
 141 (defmethod boxed-free-fn ((info g-boxed-cstruct-wrapper-info) native)
 142   (if (g-boxed-info-g-type info)
 143       (g-boxed-free (g-boxed-info-g-type info) native)
 144       (foreign-free native)))
 145
 146 (defun copy-slots-to-native (proxy native cstruct-description)
 147   (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description)))
 148         (for slot in (cstruct-description-slots cstruct-description))
 149         (for slot-name = (cstruct-slot-description-name slot))
 150         (cond
 151           ((cstruct-slot-description-count slot)
 152            (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name))
 153                  (with array = (slot-value proxy slot-name))
 154                  (for i from 0 below (cstruct-slot-description-count slot))
 155                  (setf (mem-aref ptr (cstruct-slot-description-type slot) i)
 156                        (aref array i))))
 157           ((cstruct-slot-description-inline-p slot)
 158            (let ((info (get-g-boxed-foreign-info (cstruct-inline-slot-description-boxed-type-name slot))))
 159              (copy-slots-to-native (slot-value proxy slot-name)
 160                                    (foreign-slot-pointer native cstruct-type slot-name)
 161                                    (g-boxed-cstruct-wrapper-info-cstruct-description info))))
 162           (t
 163            (setf (foreign-slot-value native cstruct-type slot-name)
 164                  (slot-value proxy slot-name))))))
 165
 166 (defun create-structure (structure-name)
 167   (let ((constructor (get structure-name 'structure-constructor)))
 168     (assert constructor nil "Don't know how to create structure of type ~A" structure-name)
 169     (funcall constructor)))
 170
 171 (defun copy-slots-to-proxy (proxy native cstruct-description)
 172   (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description)))
 173         (for slot in (cstruct-description-slots cstruct-description))
 174         (for slot-name = (cstruct-slot-description-name slot))
 175         (cond
 176           ((cstruct-slot-description-count slot)
 177            (setf (slot-value proxy slot-name) (make-array (list (cstruct-slot-description-count slot))))
 178            (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name))
 179                  (with array = (slot-value proxy slot-name))
 180                  (for i from 0 below (cstruct-slot-description-count slot))
 181                  (setf (aref array i)
 182                        (mem-aref ptr (cstruct-slot-description-type slot) i))))
 183           ((cstruct-slot-description-inline-p slot)
 184            (let ((info (get-g-boxed-foreign-info (cstruct-inline-slot-description-boxed-type-name slot))))
 185              (setf (slot-value proxy slot-name) (create-structure (cstruct-inline-slot-description-boxed-type-name slot)))
 186              (copy-slots-to-proxy (slot-value proxy slot-name)
 187                                   (foreign-slot-pointer native cstruct-type slot-name)
 188                                   (g-boxed-cstruct-wrapper-info-cstruct-description info))))
 189           (t (setf (slot-value proxy slot-name)
 190                    (foreign-slot-value native cstruct-type slot-name))))))
 191
 192 (defmethod translate-to-foreign (proxy (type boxed-cstruct-foreign-type))
 193   (if (null proxy)
 194       (null-pointer)
 195       (let* ((info (g-boxed-foreign-info type))
 196              (native-structure-type (generated-cstruct-name (g-boxed-info-name info))))
 197         (with-foreign-object (native-structure native-structure-type)
 198           (copy-slots-to-native proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
 199           (values (boxed-copy-fn info native-structure) proxy)))))
 200
 201 (defmethod free-translated-object (native-structure (type boxed-cstruct-foreign-type) proxy)
 202   (when proxy
 203     (let ((info (g-boxed-foreign-info type)))
 204       (copy-slots-to-proxy proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
 205       (boxed-free-fn info native-structure))))
 206
 207 (defmethod translate-from-foreign (native-structure (type boxed-cstruct-foreign-type))
 208   (unless (null-pointer-p native-structure)
 209     (let* ((info (g-boxed-foreign-info type))
 210            (proxy-structure-type (g-boxed-info-name info))
 211            (proxy (create-structure proxy-structure-type)))
 212       (copy-slots-to-proxy proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))
 213       (when (g-boxed-foreign-return-p type)
 214         (boxed-free-fn info native-structure))
 215       proxy)))
 216
 217 (defmethod cleanup-translated-object-for-callback ((type boxed-cstruct-foreign-type) proxy native-structure)
 218   (when proxy
 219     (let ((info (g-boxed-foreign-info type)))
 220       (copy-slots-to-native proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info)))))
 221
 222 (eval-when (:compile-toplevel :load-toplevel :execute)
 223   (defstruct (g-boxed-opaque-wrapper-info (:include g-boxed-info))
 224     alloc free))
 225
 226 (define-foreign-type boxed-opaque-foreign-type (g-boxed-foreign-type) ())
 227
 228 (defclass g-boxed-opaque ()
 229   ((pointer :initarg :pointer
 230             :initform nil
 231             :accessor g-boxed-opaque-pointer)))
 232
 233 (defmethod pointer ((object g-boxed-opaque))
 234   (g-boxed-opaque-pointer object))
 235
 236 (defmethod make-foreign-type ((info g-boxed-opaque-wrapper-info) &key return-p)
 237   (make-instance 'boxed-opaque-foreign-type :info info :return-p return-p))
 238
 239 (defmethod translate-to-foreign (proxy (type boxed-opaque-foreign-type))
 240   (if (null proxy)
 241       (null-pointer)
 242       (prog1 (g-boxed-opaque-pointer proxy)
 243         (when (g-boxed-foreign-return-p type)
 244           (tg:cancel-finalization proxy)
 245           (setf (g-boxed-opaque-pointer proxy) nil)))))
 246
 247 (defmethod free-translated-object (native (type boxed-opaque-foreign-type) param)
 248   (declare (ignore native type param)))
 249
 250 (defvar *gboxed-gc-hooks-lock* (make-recursive-lock "gboxed-gc-hooks-lock"))
 251 (defvar *gboxed-gc-hooks* nil);;pointers to objects to be freed
 252
 253 (defun activate-gboxed-gc-hooks ()
 254   (with-recursive-lock-held (*gboxed-gc-hooks-lock*)
 255     (when *gboxed-gc-hooks*
 256       (log-for :gc "activating gc hooks for boxeds: ~A~%" *gboxed-gc-hooks*)
 257       (loop
 258          for (pointer type) in *gboxed-gc-hooks*
 259          do (boxed-free-fn type pointer))
 260       (setf *gboxed-gc-hooks* nil))))
 261
 262 (defcallback gboxed-idle-gc-hook :boolean ((data :pointer))
 263   (declare (ignore data))
 264   (activate-gboxed-gc-hooks)
 265   nil)
 266
 267 (defun register-gboxed-for-gc (type pointer)
 268   (with-recursive-lock-held (*gboxed-gc-hooks-lock*)
 269     (let ((locks-were-present (not (null *gboxed-gc-hooks*))))
 270       (push (list pointer type) *gboxed-gc-hooks*)
 271       (unless locks-were-present
 272         (log-for :gc "adding gboxed idle-gc-hook to main loop~%")
 273         (g-idle-add (callback gboxed-idle-gc-hook) (null-pointer))))))
 274
 275 (defun make-boxed-free-finalizer (type pointer)
 276   (lambda () (register-gboxed-for-gc type pointer)))
 277
 278 (defmethod translate-from-foreign (native (foreign-type boxed-opaque-foreign-type))
 279   (let* ((type (g-boxed-foreign-info foreign-type))
 280          (proxy (make-instance (g-boxed-info-name type) :pointer native)))
 281     proxy))
 282
 283 (defmethod cleanup-translated-object-for-callback ((type boxed-opaque-foreign-type) proxy native)
 284   (declare (ignore native))
 285   (tg:cancel-finalization proxy)
 286   (setf (g-boxed-opaque-pointer proxy) nil))
 287
 288 (defmacro define-g-boxed-opaque (name g-type-name &key
 289                                  (alloc (error "Alloc must be specified")))
 290   (let ((native-copy (gensym "NATIVE-COPY-"))
 291         (instance (gensym "INSTANCE-")))
 292     `(progn (defclass ,name (g-boxed-opaque) ())
 293             (defmethod initialize-instance :after ((,instance ,name) &key &allow-other-keys)
 294               (unless (g-boxed-opaque-pointer ,instance)
 295                 (let ((,native-copy ,alloc))
 296                   (setf (g-boxed-opaque-pointer ,instance) ,native-copy)
 297                   (finalize ,instance (make-boxed-free-finalizer (get ',name 'g-boxed-foreign-info) ,native-copy)))))
 298             (eval-when (:compile-toplevel :load-toplevel :execute)
 299               (setf (get ',name 'g-boxed-foreign-info)
 300                     (make-g-boxed-opaque-wrapper-info :name ',name
 301                                                       :g-type ,g-type-name)
 302                     (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
 303                     (get ',name 'g-boxed-foreign-info))))))
 304
 305 (defstruct var-structure
 306   name
 307   parent
 308   slots
 309   discriminator-slot
 310   variants
 311   resulting-cstruct-description)
 312
 313 (defstruct var-structure-variant
 314   discriminating-values
 315   structure)
 316
 317 (defmethod make-load-form ((object var-structure) &optional env)
 318   (make-load-form-saving-slots object :environment env))
 319
 320 (defmethod make-load-form ((object var-structure-variant) &optional env)
 321   (make-load-form-saving-slots object :environment env))
 322
 323 (defun var-struct-all-slots (struct)
 324   (when struct
 325     (append (var-struct-all-slots (var-structure-parent struct))
 326             (var-structure-slots struct))))
 327
 328 (defun all-structures (structure)
 329   (append (iter (for variant in (var-structure-variants structure))
 330                 (appending (all-structures (var-structure-variant-structure variant))))
 331           (list structure)))
 332
 333 (defun parse-variant-structure-definition (name slots &optional parent)
 334   (iter (with result = (make-var-structure :name name
 335                                            :parent parent
 336                                            :slots nil
 337                                            :discriminator-slot nil
 338                                            :variants nil))
 339         (for slot in slots)
 340         (if (eq :variant (first slot))
 341             (progn
 342               (when (var-structure-discriminator-slot result)
 343                 (error "Structure has more than one discriminator slot"))
 344               (setf (var-structure-discriminator-slot result) (second slot)
 345                     (var-structure-variants result) (parse-variants result (nthcdr 2 slot))))
 346             (push (parse-cstruct-slot slot) (var-structure-slots result)))
 347         (finally (setf (var-structure-slots result)
 348                        (reverse (var-structure-slots result)))
 349                  (unless parent
 350                    (set-variant-result-structure result))
 351                  (return result))))
 352
 353 (defun set-variant-result-structure (var-structure)
 354   (setf (var-structure-resulting-cstruct-description var-structure)
 355         (make-cstruct-description
 356          :name
 357          (var-structure-name var-structure)
 358          :slots
 359          (append
 360           (when (var-structure-parent var-structure)
 361             (cstruct-description-slots (var-structure-resulting-cstruct-description (var-structure-parent var-structure))))
 362           (var-structure-slots var-structure))))
 363   (iter (for variant in (var-structure-variants var-structure))
 364         (for child-var-structure = (var-structure-variant-structure variant))
 365         (set-variant-result-structure child-var-structure)))
 366
 367 (defun ensure-list (thing)
 368   (if (listp thing)
 369       thing
 370       (list thing)))
 371
 372 (defun parse-variants (parent variants)
 373   (iter (for (options variant-name . slots) in variants)
 374         (for variant =
 375              (make-var-structure-variant
 376               :discriminating-values (ensure-list options)
 377               :structure (parse-variant-structure-definition variant-name slots parent)))
 378         (collect variant)))
 379
 380 (defun generated-cstruct-name (symbol)
 381   (intern (format nil "~A-CSTRUCT" (symbol-name symbol)) (symbol-package symbol)))
 382
 383 (defun generated-cunion-name (symbol)
 384   (intern (format nil "~A-CUNION" (symbol-name symbol)) (symbol-package symbol)))
 385
 386 (defun generate-cstruct-1 (struct)
 387   (let ((cstruct-name (generated-cstruct-name (cstruct-description-name struct))))
 388     `((defcstruct ,cstruct-name
 389         ,@(iter (for slot in (cstruct-description-slots struct))
 390                 (collect `(,(cstruct-slot-description-name slot) ,(cstruct-slot-description-type slot)
 391                             ,@(when (cstruct-slot-description-count slot)
 392                                    `(:count ,(cstruct-slot-description-count slot)))))))
 393       (defctype ,cstruct-name (:struct ,cstruct-name)))))
 394
 395 (defun generate-c-structures (structure)
 396   (iter (for str in (all-structures structure))
 397         (for cstruct = (var-structure-resulting-cstruct-description str))
 398         (nconcing (generate-cstruct-1 cstruct))))
 399
 400 (defun generate-variant-union (struct)
 401   (let ((cunion-name (generated-cunion-name (var-structure-name struct))))
 402     `((defcunion ,cunion-name
 403         ,@(iter (for str in (all-structures struct))
 404                 (collect `(,(var-structure-name str)
 405                             ,(generated-cstruct-name (var-structure-name str))))))
 406       (defctype ,cunion-name (:union ,cunion-name)))))
 407
 408 (defun generate-structure-1 (str)
 409   (let ((name (var-structure-name str)))
 410     `(progn
 411        (defstruct ,(if (var-structure-parent str)
 412                        `(,(var-structure-name str) (:include ,(var-structure-name (var-structure-parent str))
 413                                                              (,(var-structure-discriminator-slot (var-structure-parent str))
 414                                                                ,(first (var-structure-variant-discriminating-values
 415                                                                         (find str
 416                                                                               (var-structure-variants
 417                                                                                (var-structure-parent str))
 418                                                                               :key #'var-structure-variant-structure))))))
 419                        `,(var-structure-name str))
 420          ,@(iter (for slot in (var-structure-slots str))
 421                  (collect `(,(cstruct-slot-description-name slot)
 422                              ,(cstruct-slot-description-initform slot)))))
 423        (setf (get ',name 'structure-constructor)
 424              ',(intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name))))))
 425
 426 (defun generate-structures (str)
 427   (iter (for variant in (reverse (all-structures str)))
 428         (collect (generate-structure-1 variant))))
 429
 430 (defun generate-native-type-decision-procedure-1 (str proxy-var)
 431   (if (null (var-structure-discriminator-slot str))
 432       `(values ',(var-structure-resulting-cstruct-description str))
 433       `(typecase ,proxy-var
 434          ,@(iter (for variant in (var-structure-variants str))
 435                  (for v-str = (var-structure-variant-structure variant))
 436                  (collect `(,(var-structure-name v-str)
 437                              ,(generate-native-type-decision-procedure-1 v-str proxy-var))))
 438          (,(var-structure-name str)
 439           (values ',(var-structure-resulting-cstruct-description str))))))
 440
 441 (defun generate-proxy-type-decision-procedure-1 (str native-var)
 442   (if (null (var-structure-discriminator-slot str))
 443       `(values ',(var-structure-name str)
 444                ',(var-structure-resulting-cstruct-description str))
 445       `(case (foreign-slot-value ,native-var
 446                                  ',(generated-cstruct-name (var-structure-name str))
 447                                  ',(var-structure-discriminator-slot str))
 448          ,@(iter (for variant in (var-structure-variants str))
 449                  (for v-str = (var-structure-variant-structure variant))
 450                  (collect `(,(var-structure-variant-discriminating-values variant)
 451                              ,(generate-proxy-type-decision-procedure-1
 452                                v-str
 453                                native-var))))
 454          (t (values ',(var-structure-name str)
 455                     ',(var-structure-resulting-cstruct-description str))))))
 456
 457 (defun generate-proxy-type-decision-procedure (str)
 458   (let ((native (gensym "NATIVE-")))
 459     `(lambda (,native)
 460        (declare (ignorable ,native))
 461        ,(generate-proxy-type-decision-procedure-1 str native))))
 462
 463 (defun generate-native-type-decision-procedure (str)
 464   (let ((proxy (gensym "PROXY-")))
 465     `(lambda (,proxy)
 466        (declare (ignorable ,proxy))
 467        ,(generate-native-type-decision-procedure-1 str proxy))))
 468
 469 (defun compile-proxy-type-decision-procedure (str)
 470   (compile nil (generate-proxy-type-decision-procedure str)))
 471
 472 (defun compile-native-type-decision-procedure (str)
 473   (compile nil (generate-native-type-decision-procedure str)))
 474
 475 (defstruct (g-boxed-variant-cstruct-info (:include g-boxed-info))
 476   root
 477   native-type-decision-procedure
 478   proxy-type-decision-procedure)
 479
 480 (defmethod make-load-form ((object g-boxed-variant-cstruct-info) &optional env)
 481   (make-load-form-saving-slots object :environment env))
 482
 483 (define-foreign-type boxed-variant-cstruct-foreign-type (g-boxed-foreign-type) ())
 484
 485 (defmethod make-foreign-type ((info g-boxed-variant-cstruct-info) &key return-p)
 486   (make-instance 'boxed-variant-cstruct-foreign-type :info info :return-p return-p))
 487
 488 (defmacro define-g-boxed-variant-cstruct (name g-type-name &body slots)
 489   (let* ((structure (parse-variant-structure-definition name slots)))
 490     `(progn ,@(generate-c-structures structure)
 491             ,@(generate-variant-union structure)
 492             ,@(generate-structures structure)
 493             (eval-when (:compile-toplevel :load-toplevel :execute)
 494               (setf (get ',name 'g-boxed-foreign-info)
 495                     (make-g-boxed-variant-cstruct-info :name ',name
 496                                                        :g-type ,g-type-name
 497                                                        :root ,structure
 498                                                        :native-type-decision-procedure
 499                                                        ,(generate-native-type-decision-procedure structure)
 500                                                        :proxy-type-decision-procedure
 501                                                        ,(generate-proxy-type-decision-procedure structure))
 502                     (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*)
 503                     (get ',name 'g-boxed-foreign-info))))))
 504
 505 (defun decide-native-type (info proxy)
 506   (funcall (g-boxed-variant-cstruct-info-native-type-decision-procedure info) proxy))
 507
 508 (defmethod boxed-copy-fn ((info g-boxed-variant-cstruct-info) native)
 509   (if (g-boxed-info-g-type info)
 510       (g-boxed-copy (g-boxed-info-g-type info) native)
 511       (let ((copy (foreign-alloc (generated-cunion-name (g-boxed-info-name info)))))
 512         (memcpy copy native (foreign-type-size (generated-cunion-name (g-boxed-info-name info))))
 513         copy)))
 514
 515 (defmethod boxed-free-fn ((info g-boxed-variant-cstruct-info) native)
 516   (if (g-boxed-info-g-type info)
 517       (g-boxed-free (g-boxed-info-g-type info) native)
 518       (foreign-free native)))
 519
 520 (defmethod translate-to-foreign (proxy (foreign-type boxed-variant-cstruct-foreign-type))
 521   (if (null proxy)
 522       (null-pointer)
 523       (let* ((type (g-boxed-foreign-info foreign-type))
 524              (cstruct-description (decide-native-type type proxy)))
 525         (with-foreign-object (native-structure (generated-cunion-name
 526                                                 (var-structure-name
 527                                                  (g-boxed-variant-cstruct-info-root type))))
 528           (copy-slots-to-native proxy native-structure cstruct-description)
 529           (values (boxed-copy-fn type native-structure) proxy)))))
 530
 531 (defun decide-proxy-type (info native-structure)
 532   (funcall (g-boxed-variant-cstruct-info-proxy-type-decision-procedure info) native-structure))
 533
 534 (defmethod free-translated-object (native (foreign-type boxed-variant-cstruct-foreign-type) proxy)
 535   (when proxy
 536     (let ((type (g-boxed-foreign-info foreign-type)))
 537       (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native)
 538         (unless (eq (type-of proxy) actual-struct)
 539           (restart-case
 540               (error "Expected type of boxed variant structure ~A and actual type ~A do not match"
 541                      (type-of proxy) actual-struct)
 542             (skip-parsing-values () (return-from free-translated-object))))
 543         (copy-slots-to-proxy proxy native cstruct-description)
 544         (boxed-free-fn type native)))))
 545
 546 (defmethod translate-from-foreign (native (foreign-type boxed-variant-cstruct-foreign-type))
 547   (unless (null-pointer-p native)
 548     (let ((type (g-boxed-foreign-info foreign-type)))
 549       (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native)
 550         (let ((proxy (create-structure actual-struct)))
 551           (copy-slots-to-proxy proxy native cstruct-description)
 552           (when (g-boxed-foreign-return-p foreign-type)
 553             (boxed-free-fn type native))
 554           proxy)))))
 555
 556 (defmethod cleanup-translated-object-for-callback ((foreign-type boxed-variant-cstruct-foreign-type) proxy native)
 557   (when proxy
 558     (let ((type (g-boxed-foreign-info foreign-type)))
 559       (let ((cstruct-description (decide-native-type type proxy)))
 560         (copy-slots-to-native proxy native cstruct-description)))))
 561
 562 (defgeneric boxed-parse-g-value (gvalue-ptr info))
 563
 564 (defgeneric boxed-set-g-value (gvalue-ptr info proxy))
 565
 566 (defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql (gtype +g-type-boxed+))) parse-kind)
 567   (declare (ignore parse-kind))
 568   (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
 569       (convert-from-foreign (g-value-get-boxed gvalue-ptr) '(glib:gstrv :free-from-foreign nil))
 570       (let ((boxed-type (get-g-boxed-foreign-info-for-gtype (g-value-type gvalue-ptr))))
 571         (boxed-parse-g-value gvalue-ptr boxed-type))))
 572
 573 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql (gtype +g-type-boxed+))) value)
 574   (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
 575       (g-value-set-boxed gvalue-ptr (convert-to-foreign value '(glib:gstrv :free-from-foreign nil)))
 576       (let ((boxed-type (get-g-boxed-foreign-info-for-gtype (g-value-type gvalue-ptr))))
 577         (boxed-set-g-value gvalue-ptr boxed-type value))))
 578
 579 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-cstruct-wrapper-info))
 580   (translate-from-foreign (g-value-get-boxed gvalue-ptr) (make-foreign-type info :return-p nil)))
 581
 582 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-cstruct-wrapper-info) proxy)
 583   (g-value-take-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
 584
 585 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-variant-cstruct-info))
 586   (translate-from-foreign (g-value-get-boxed gvalue-ptr) (make-foreign-type info :return-p nil)))
 587
 588 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-variant-cstruct-info) proxy)
 589   (g-value-take-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
 590
 591 (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-opaque-wrapper-info))
 592   (translate-from-foreign (g-value-get-boxed gvalue-ptr) (make-foreign-type info :return-p t)))
 593
 594 (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-opaque-wrapper-info) proxy)
 595   (g-value-set-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil))))
 596
 597 (defun boxed-related-symbols (name)
 598   (let ((info (get-g-boxed-foreign-info name)))
 599     (etypecase info
 600       (g-boxed-cstruct-wrapper-info
 601        (append (list name
 602                      (intern (format nil "MAKE-~A" (symbol-name name)))
 603                      (intern (format nil "COPY-~A" (symbol-name name))))
 604                (iter (for slot in (cstruct-description-slots (g-boxed-cstruct-wrapper-info-cstruct-description info)))
 605                      (for slot-name = (cstruct-slot-description-name slot))
 606                      (collect (intern (format nil "~A-~A" (symbol-name name) (symbol-name slot-name)))))))
 607       (g-boxed-opaque-wrapper-info
 608        (list name))
 609       (g-boxed-variant-cstruct-info
 610        (append (list name)
 611                (iter (for var-struct in (all-structures (g-boxed-variant-cstruct-info-root info)))
 612                      (for s-name = (var-structure-name var-struct))
 613                      (for cstruct-description = (var-structure-resulting-cstruct-description var-struct))
 614                      (appending (append (list s-name)
 615                                         (list (intern (format nil "MAKE-~A" (symbol-name s-name)))
 616                                               (intern (format nil "COPY-~A" (symbol-name s-name))))
 617                                         (iter (for slot in (cstruct-description-slots cstruct-description))
 618                                               (for slot-name = (cstruct-slot-description-name slot))
 619                                               (collect (intern (format nil "~A-~A" (symbol-name s-name)
 620                                                                        (symbol-name slot-name)))))))))))))
 621
 622 (defmacro define-boxed-opaque-accessor (boxed-name accessor-name &key type reader writer)
 623   (let ((var (gensym))
 624         (n-var (gensym)))
 625     `(progn ,@(when reader
 626                     (list (etypecase reader
 627                             (symbol `(defun ,accessor-name (,var)
 628                                        (funcall ,reader ,var)))
 629                             (string `(defcfun (,accessor-name ,reader) ,type
 630                                        (,var (g-boxed-foreign ,boxed-name)))))))
 631             ,@(when writer
 632                     (list (etypecase reader
 633                             (symbol `(defun (setf ,accessor-name) (,n-var ,var)
 634                                        (funcall ,reader ,n-var ,var)))
 635                             (string `(defun (setf ,accessor-name) (,n-var ,var)
 636                                        (foreign-funcall ,writer (g-boxed-foreign ,boxed-name) ,var ,type ,n-var :void)))))))))
 637
 638 (defun copy-boxed-slots-to-foreign (structure native-ptr &optional (type (and structure (type-of structure))))
 639   (when structure
 640     (copy-slots-to-native
 641      structure
 642      native-ptr
 643      (g-boxed-cstruct-wrapper-info-cstruct-description (get-g-boxed-foreign-info type)))))
 644
 645 (define-compiler-macro copy-boxed-slots-to-foreign (&whole whole structure native-ptr &optional type)
 646   (if (and type
 647            (constantp type))
 648       (let* ((type-r (eval type))
 649              (f-i (get-g-boxed-foreign-info type-r)))
 650         (unless f-i
 651           (warn "Unknown foreign GBoxed type ~S" type-r)
 652           (return-from copy-boxed-slots-to-foreign whole))
 653         (unless (typep f-i 'g-boxed-cstruct-wrapper-info)
 654           (warn "Foreign GBoxed type ~S is not a C structure wrapper" type-r)
 655           (return-from copy-boxed-slots-to-foreign whole))
 656         `(when ,structure
 657            (copy-slots-to-native
 658             ,structure
 659             ,native-ptr
 660             (load-time-value (g-boxed-cstruct-wrapper-info-cstruct-description (get-g-boxed-foreign-info ',type-r))))))
 661       whole))
 662
 663 (defmacro with-foreign-boxed-array ((n-var array-var type values-seq) &body body)
 664   (let ((values-seq-1 (gensym "VALUES-SEQ-"))
 665         (cstruct (generated-cstruct-name type))
 666         (x (gensym "X-"))
 667         (i (gensym "I-")))
 668     `(let* ((,values-seq-1 ,values-seq)
 669             (,n-var (length ,values-seq-1)))
 670        (with-foreign-object (,array-var ',cstruct ,n-var)
 671          (let ((,i 0))
 672            (map nil (lambda (,x)
 673                       (copy-boxed-slots-to-foreign
 674                        ,x
 675                        (inc-pointer ,array-var (* ,i (foreign-type-size ',cstruct)))
 676                        ',type)
 677                       (incf ,i))
 678                 ,values-seq-1))
 679          ,@body))))