glib/gobject.foreign-gboxed.lisp

   1 (in-package :gobject)
   2
   3 (defun ensure-list (thing)
   4   (if (listp thing) thing (list thing)))
   5
   6 (defun slot->cstruct-slot (slot)
   7   (destructuring-bind (name type &key &allow-other-keys) slot
   8     `(,name ,type)))
   9
  10 (defun slot->slot-name (slot)
  11   (destructuring-bind (name type &key &allow-other-keys) slot
  12     (declare (ignore type))
  13     name))
  14
  15 (defun cstruct-definition (name slots)
  16   `(defcstruct ,name ,@(mapcar #'slot->cstruct-slot slots)))
  17
  18 (defun maybe-unlist (thing)
  19   (if (or (not (listp thing)) (cdr thing))
  20       thing
  21       (car thing)))
  22
  23 (defun slot->struct-slot (slot)
  24   (destructuring-bind (name type &key initform &allow-other-keys) slot
  25     (declare (ignore type))
  26     (maybe-unlist `(,name ,@(when initform (list initform))))))
  27
  28 (defun struct-definition (name superclass slots)
  29   `(defstruct ,@(if superclass
  30                     (list `(,name (:include ,superclass)))
  31                     (list name))
  32      ,@(mapcar #'slot->struct-slot slots)))
  33
  34 (define-foreign-type g-boxed-pointer-type ()
  35   ((name :accessor g-boxed-pointer-type-name :initarg :name)
  36    (outp :accessor g-boxed-pointer-type-outp :initarg :outp)))
  37
  38 (define-parse-method g-boxed-ptr (name &optional (type :in))
  39   (make-instance 'g-boxed-pointer-type :name name :actual-type :pointer :outp (ecase type
  40                                                                                 (:in nil)
  41                                                                                 (:in-out t))))
  42
  43 (defmethod translate-from-foreign (value (type g-boxed-pointer-type))
  44   (unless (null-pointer-p value)
  45     (parse-g-boxed value (g-boxed-pointer-type-name type))))
  46
  47 (defmethod translate-to-foreign (value (type g-boxed-pointer-type))
  48   (if value
  49       (let ((ptr (foreign-alloc (boxed-c-structure-name (g-boxed-pointer-type-name type)))))
  50         (real-unparse-g-boxed ptr value)
  51         (values ptr value))
  52       (null-pointer)))
  53
  54 (defmethod free-translated-object (ptr (type g-boxed-pointer-type) param)
  55   (unless (null-pointer-p ptr)
  56     (when (g-boxed-pointer-type-outp type)
  57       (let ((original-object param)
  58             (new-real-name (g-boxed-real-name ptr (g-boxed-pointer-type-name type))))
  59         (if (eq new-real-name (type-of original-object))
  60             (real-parse-g-boxed ptr original-object)
  61             (error "Type has changed!")))))
  62   (foreign-free ptr))
  63
  64 (defmethod expand-to-foreign-dyn (value var body (type g-boxed-pointer-type))
  65   (let ((value-var (gensym)))
  66     `(with-foreign-object (,var ',(boxed-c-structure-name (g-boxed-pointer-type-name type)))
  67        (let ((,value-var ,value))
  68          (when ,value-var
  69            (real-unparse-g-boxed ,var ,value-var))
  70          (if (null ,value-var)
  71              (let ((,var (null-pointer)))
  72                ,@body)
  73              (progn ,@body
  74                     ,@(when (g-boxed-pointer-type-outp type)
  75                             (list `(when ,value-var
  76                                      (let ((new-real-name (g-boxed-real-name ,var ',(g-boxed-pointer-type-name type))))
  77                                        (if (eq new-real-name (type-of ,value-var))
  78                                            (real-parse-g-boxed ,var ,value-var)
  79                                            (error "Type has changed from ~A to ~A" (type-of ,value-var) new-real-name))))))))))))
  80
  81 (define-foreign-type g-boxed-inline-type ()
  82   ((name :accessor g-boxed-inline-type :initarg :name)))
  83
  84 (define-parse-method g-boxed-inline (name)
  85   (make-instance 'g-boxed-inline-type :name name :actual-type name))
  86
  87 (defgeneric real-parse-g-boxed (pointer object))
  88 (defgeneric real-unparse-g-boxed (pointer object))
  89
  90 (defun parse-g-boxed (pointer name)
  91   (unless (null-pointer-p pointer)
  92     (let* ((real-name (g-boxed-real-name pointer name))
  93            (object (make-instance real-name)))
  94       (real-parse-g-boxed pointer object)
  95       object)))
  96
  97 (defun boxed-alloc (type alloc-type)
  98   (ecase alloc-type
  99     (:cffi (foreign-alloc type))
 100     (:boxed (let ((pointer (foreign-alloc type)))
 101               (prog1 (g-boxed-copy (g-type-from-name (boxed-type-gname type)) pointer)
 102                 (foreign-free pointer))))))
 103
 104 (defun g-boxed->cstruct (object &key (alloc-type :cffi))
 105   (let ((pointer (boxed-alloc (type-of object) alloc-type)))
 106     (real-unparse-g-boxed pointer object)
 107     pointer))
 108
 109 (defun g-boxed-real-name (pointer name)
 110   (or (loop
 111          for (sub-name slot values) in (get name 'boxed-dispatch)
 112          do (debugf "Checking ~A ~A ~A against ~A.~A = ~A~%" sub-name slot values name slot (foreign-slot-value pointer name slot))
 113          when (member (foreign-slot-value pointer name slot) values :test 'equalp)
 114          return (g-boxed-real-name pointer sub-name))
 115       name))
 116
 117 (defun slot->slot-parser (class-name pointer-var slot)
 118   (destructuring-bind (slot-name slot-type &key parser &allow-other-keys) slot
 119     (cond
 120       (parser
 121        `(setf ,slot-name (funcall ,parser ',class-name ,pointer-var)))
 122       ((and (listp slot-type) (eq 'g-boxed-inline (first slot-type)))
 123        `(setf ,slot-name (parse-g-boxed (foreign-slot-pointer ,pointer-var ',class-name ',slot-name) ',(second slot-type))))
 124       (t
 125        `(setf ,slot-name (foreign-slot-value ,pointer-var ',class-name ',slot-name))))))
 126
 127 (defun parse-method-definition (name slots)
 128   (let ((slot-names (mapcar #'slot->slot-name slots)))
 129     `(defmethod real-parse-g-boxed (pointer (object ,name))
 130        (with-slots (,@slot-names) object
 131          ,@(mapcar (lambda (slot) (slot->slot-parser name 'pointer slot)) slots)))))
 132
 133 (defun slot->slot-unparser (class-name pointer-var slot object)
 134   (destructuring-bind (slot-name slot-type &key unparser &allow-other-keys) slot
 135     (cond
 136       (unparser
 137        `(funcall ,unparser ',class-name ,pointer-var ,object))
 138       ((and (listp slot-type) (eq 'g-boxed-inline (first slot-type)))
 139        `(real-unparse-g-boxed (foreign-slot-pointer ,pointer-var ',class-name ',slot-name) ,slot-name))
 140       (t
 141        `(setf (foreign-slot-value ,pointer-var ',class-name ',slot-name) ,slot-name)))))
 142
 143 (defun unparse-method-definition (name slots)
 144   (let ((slot-names (mapcar #'slot->slot-name slots)))
 145     `(defmethod real-unparse-g-boxed (pointer (object ,name))
 146        (with-slots (,@slot-names) object
 147          ,@(mapcar (lambda (slot) (slot->slot-unparser name 'pointer slot 'object)) slots)))))
 148
 149 (defun slot->export-accessor (class-name slot)
 150   (destructuring-bind (slot-name slot-type &key &allow-other-keys) slot
 151     (declare (ignore slot-type))
 152     (let ((accessor-name (intern (format nil "~A-~A" (symbol-name class-name) (symbol-name slot-name))
 153                                  (symbol-package class-name))))
 154       `(export ',accessor-name (symbol-package ',accessor-name)))))
 155
 156 (defun struct-constructor-name (name)
 157   (intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name)))
 158
 159 (defun get-g-boxed-direct-subclasses (name)
 160   (mapcar (lambda (spec) (destructuring-bind (name slot values) spec
 161                            (declare (ignore slot values))
 162                            name))
 163           (get name 'boxed-dispatch)))
 164
 165 (defun map-append (f &rest lists)
 166   (reduce #'append (apply #'mapcar f lists)))
 167
 168 (defun get-g-boxed-all-subclasses (name)
 169   (cons name
 170         (map-append #'get-g-boxed-all-subclasses (get-g-boxed-direct-subclasses name))))
 171
 172 (defun get-g-boxed-completed-c-definition (name union-name)
 173   `(defcunion ,union-name
 174      ,@(mapcar (lambda (sub-name)
 175                  `(,sub-name ,sub-name))
 176                (get-g-boxed-all-subclasses name))))
 177
 178 (defun g-boxed-root (name)
 179   (if (get name 'superclass)
 180       (g-boxed-root (get name 'superclass))
 181       name))
 182
 183 (defmacro update-g-boxed-root-c-class (name)
 184   (when (get name 'c-name)
 185     (get-g-boxed-completed-c-definition (g-boxed-root name) (get name 'c-name))))
 186
 187 (defmacro define-g-boxed-class (g-name-and-c-name name (&optional superclass-and-dispatch (export t)) &body slots)
 188   (destructuring-bind (&optional g-name c-name) (ensure-list g-name-and-c-name)
 189     (destructuring-bind (&optional superclass dispatch-slot dispatch-values) superclass-and-dispatch
 190       (let* ((superclass-slots (get superclass 'boxed-combined-slots))
 191              (combined-slots (append superclass-slots slots)))
 192
 193         (setf c-name (or c-name (gensym "C-UNION-")))
 194         `(progn ,(cstruct-definition name combined-slots)
 195                 ,(struct-definition name superclass slots)
 196                 ,(parse-method-definition name combined-slots)
 197                 ,(unparse-method-definition name combined-slots)
 198                 (eval-when (:load-toplevel :compile-toplevel :execute)
 199                   (setf (get ',name 'boxed-slots) ',slots
 200                         (get ',name 'boxed-combined-slots) ',combined-slots
 201                         (get ',name 'superclass) ',superclass
 202                         (get ',name 'c-name) (or (get ',name 'c-name) ',c-name))
 203                   ,@(when superclass
 204                           (list `(pushnew '(,name ,dispatch-slot ,(ensure-list dispatch-values)) (get ',superclass 'boxed-dispatch) :test 'equalp))))
 205                 (update-g-boxed-root-c-class ,name)
 206                 ,@(when g-name
 207                         (list `(register-boxed-type ,g-name ',name)))
 208                 ,@(when export
 209                         (append (list `(export ',name (symbol-package ',name))
 210                                       `(export ',(struct-constructor-name name) (symbol-package ',(struct-constructor-name name))))
 211                                 (mapcar (lambda (slot) (slot->export-accessor name slot)) slots))))))))
 212
 213 (defun boxed-c-structure-name (name)
 214   (get (g-boxed-root name) 'c-name))
 215
 216 (defclass g-boxed-ref () ((pointer :accessor pointer :initarg :pointer)))
 217
 218 (defvar *g-boxed-gc-lock* (make-recursive-lock "g-boxed-gc-lock"))
 219 (defvar *known-boxed-refs* (tg:make-weak-hash-table :test 'equal :weakness :value))
 220 (defvar *boxed-ref-count* (make-hash-table :test 'equal))
 221 (defvar *boxed-ref-owner* (make-hash-table :test 'equal))
 222
 223 (defun boxed-ref-free-function (name)
 224   (or (get name 'free-function)
 225       (error "g-boxed-ref class ~A has no free-function" name)))
 226
 227 (defun disown-boxed-ref (object)
 228   (setf (gethash (pointer-address (pointer object)) *boxed-ref-owner*) :foreign))
 229
 230 (defun dispose-boxed-ref (type pointer)
 231   (debugf "disposing g-boxed-ref ~A~%" pointer)
 232
 233   (unless (gethash (pointer-address pointer) *boxed-ref-count*)
 234     (error "g-boxed-ref ~A is already disposed from lisp-side" pointer))
 235   (with-recursive-lock-held (*g-boxed-gc-lock*)
 236     (let ((object (gethash (pointer-address pointer) *known-boxed-refs*)))
 237       (when object
 238         (debugf "Removing finalization from ~A for pointer ~A~%" object pointer)
 239         (tg:cancel-finalization object)))
 240     (when (eq :lisp (gethash (pointer-address pointer) *boxed-ref-owner*))
 241       (funcall (boxed-ref-free-function type) pointer))
 242     (remhash (pointer-address pointer) *known-boxed-refs*)
 243     (remhash (pointer-address pointer) *boxed-ref-count*)
 244     (remhash (pointer-address pointer) *boxed-ref-owner*)
 245     (debugf "Disposed of g-boxed-ref ~A (object ~A)~%"
 246             pointer
 247             (gethash (pointer-address pointer) *known-boxed-refs*))))
 248
 249 (defmethod initialize-instance :after ((object g-boxed-ref) &key)
 250   (with-recursive-lock-held (*g-boxed-gc-lock*)
 251     (let ((address (pointer-address (pointer object))))
 252       (let ((object (gethash address *known-boxed-refs*)))
 253         (when object
 254           (tg:cancel-finalization object)))
 255       (setf (gethash address *known-boxed-refs*) object)
 256       (setf (gethash address *boxed-ref-count*) 1)
 257       (setf (gethash address *boxed-ref-owner*)
 258             (gethash address *boxed-ref-owner* :foreign)))
 259     (debugf "setting g-boxed-ref-count of ~A (for ptr ~A) to 1~%" object (pointer object))
 260     (let ((p (pointer object))
 261           (type (type-of object))
 262           (s (format nil "~A" object)))
 263       (tg:finalize object (lambda ()
 264                             (handler-case
 265                                 (dispose-boxed-ref type p)
 266                               (error (e) (format t "Error ~A for ~A~%" e s))))))))
 267
 268 (defmethod release ((object g-boxed-ref))
 269   (debugf "releasing g-boxed-ref ~A~%" (pointer object))
 270   (unless (gethash (pointer-address (pointer object)) *boxed-ref-count*)
 271     (error "g-boxed-ref ~A is already disposed from lisp-side" (pointer object)))
 272   (decf (gethash (pointer-address (pointer object)) *boxed-ref-count*))
 273   (when (zerop (gethash (pointer-address (pointer object)) *boxed-ref-count*))
 274     (dispose-boxed-ref (type-of object) (pointer object))))
 275
 276 (define-foreign-type g-boxed-ref-type ()
 277   ((class-name :reader g-boxed-ref-class-name :initarg :class-name)
 278    (owner :reader g-boxed-ref-owner :initarg :owner :initform nil))
 279   (:actual-type :pointer))
 280
 281 (define-parse-method g-boxed-ref (class-name &key (owner :foreign))
 282   (unless (get class-name 'is-g-boxed-ref)
 283     (error "~A is not a subtype of G-BOXED-REF (~A: ~S)" class-name class-name (symbol-plist class-name)))
 284   (make-instance 'g-boxed-ref-type :class-name class-name :owner owner))
 285
 286 (defmethod translate-to-foreign (value (type g-boxed-ref-type))
 287   (if value
 288       (pointer value)
 289       (null-pointer)))
 290
 291 (defun convert-g-boxed-ref-from-pointer (pointer name type)
 292   (unless (null-pointer-p pointer)
 293     (with-recursive-lock-held (*g-boxed-gc-lock*)
 294       (or (let ((object (gethash (pointer-address pointer) *known-boxed-refs*)))
 295             (when object (debugf "Boxed-ref for ~A is found (~A)~%" pointer object))
 296             (when object (incf (gethash (pointer-address pointer) *boxed-ref-count*)))
 297             object)
 298           (let ((object (make-instance name :pointer pointer)))
 299             (setf (gethash (pointer-address pointer) *boxed-ref-owner*) (g-boxed-ref-owner type))
 300             (debugf "Boxed-ref for ~A is created (~A) with owner ~A~%" pointer object
 301                     (gethash (pointer-address pointer) *boxed-ref-owner*))
 302             object)))))
 303
 304 (defmethod translate-from-foreign (value (type g-boxed-ref-type))
 305   (let ((owner (or (gethash (pointer-address value) *boxed-ref-owner*) (g-boxed-ref-owner type)))) ;;This is needed to prevent changing ownership of already created
 306     (prog1
 307         (convert-g-boxed-ref-from-pointer value (g-boxed-ref-class-name type) type)
 308       (setf (gethash (pointer-address value) *boxed-ref-owner*) owner))))
 309
 310 (defun g-boxed-ref-slot->methods (class slot)
 311   (destructuring-bind (slot-name &key reader writer type (accessor slot-name)) slot
 312     `(progn ,@(when reader
 313                     (list `(defmethod ,accessor ((object ,class))
 314                              ,(if (stringp reader)
 315                                   `(foreign-funcall ,reader :pointer (pointer object) ,type)
 316                                   `(,reader object)))))
 317             ,@(when writer
 318                     (list `(defmethod (setf ,accessor) (new-value (object ,class))
 319                              ,(if (stringp writer)
 320                                   `(foreign-funcall ,writer :pointer (pointer object) ,type new-value)
 321                                   `(,writer new-value object))))))))
 322
 323 (defmacro define-g-boxed-ref (gobject-name name &rest properties)
 324   (let ((free-fn (second (find :free-function properties :key 'first)))
 325         (alloc-fn (second (find :alloc-function properties :key 'first)))
 326         (slots (rest (find :slots properties :key 'first))))
 327     (unless (and free-fn alloc-fn) (error "All of :free-function, :alloc-function must be specified"))
 328     `(progn (defclass ,name (g-boxed-ref) ())
 329             (defmethod initialize-instance :before ((object ,name) &key pointer)
 330               (unless (or pointer (slot-boundp object 'pointer))
 331                 (setf (pointer object) (,alloc-fn)
 332                       (gethash (pointer-address (pointer object)) *boxed-ref-owner*) :lisp)))
 333             (setf (get ',name 'free-function) ',free-fn)
 334             (eval-when (:compile-toplevel :load-toplevel :execute)
 335               (setf (get ',name 'is-g-boxed-ref) t))
 336             ,@(mapcar (lambda (slot)
 337                         (g-boxed-ref-slot->methods name slot))
 338                       slots)
 339             (register-boxed-type ,gobject-name ',name))))
 340
 341 (define-foreign-type fixed-array ()
 342   ((element-type :reader fixed-array-element-type :initarg :element-type :initform (error "Element type must be specified"))
 343    (array-size :reader fixed-array-array-size :initarg :array-size :initform (error "Array size must be specified")))
 344   (:actual-type :pointer))
 345
 346 (define-parse-method fixed-array (element-type array-size)
 347   (make-instance 'fixed-array :element-type element-type :array-size array-size))
 348
 349 (defmethod translate-from-foreign (ptr (type fixed-array))
 350   (when (not (null-pointer-p ptr))
 351     (let ((result (make-array (fixed-array-array-size type)))
 352           (el-type (fixed-array-element-type type)))
 353       (loop
 354          for i from 0 below (fixed-array-array-size type)
 355          do (setf (aref result i) (mem-aref ptr el-type i)))
 356       result)))
 357
 358 (defvar *registered-boxed-types* (make-hash-table :test 'equal))
 359 (defvar *registered-boxed-names* (make-hash-table))
 360 (defun register-boxed-type (name type)
 361   (setf (gethash name *registered-boxed-types*) type
 362         (gethash type *registered-boxed-names*) name))
 363 (defun get-registered-boxed-type (name)
 364   (gethash name *registered-boxed-types*))
 365
 366 (defun boxed-type-gname (type)
 367   (gethash type *registered-boxed-names*))
 368
 369 (defun set-gvalue-boxed (gvalue value)
 370   (if value
 371       (progn
 372         (cond
 373           ((typep value 'g-boxed-ref)
 374            (g-value-set-boxed gvalue (pointer value)))
 375           (t (g-value-take-boxed gvalue (g-boxed->cstruct value :alloc-type :boxed)))))
 376       (g-value-set-boxed gvalue (null-pointer))))
 377
 378 (defun parse-gvalue-boxed (gvalue)
 379   (let* ((g-type (gvalue-type gvalue))
 380          (type-name (g-type-name g-type))
 381          (boxed-type (get-registered-boxed-type type-name)))
 382     (unless boxed-type
 383       (warn "Type ~A is a not registered GBoxed~%" type-name)
 384       (return-from parse-gvalue-boxed nil))
 385     (unless (null-pointer-p (g-value-get-boxed gvalue))
 386       (cond
 387         ((subtypep boxed-type 'g-boxed-ref) (convert-g-boxed-ref-from-pointer (g-value-get-boxed gvalue) boxed-type (make-instance 'g-boxed-ref-type :class-name boxed-type :owner :foreign)))
 388         (t (parse-g-boxed (g-value-get-boxed gvalue) boxed-type))))))