glib/gobject.foreign-gobject-subclassing.lisp

   1 (in-package :gobject)
   2
   3 (defvar *registered-types* (make-hash-table :test 'equal))
   4
   5 (defstruct object-type name class parent interfaces properties)
   6
   7 (defun instance-init (instance class)
   8   (log-for :subclass "(instance-init ~A ~A)~%" instance class)
   9   (log-for :subclass "Initializing instance ~A for type ~A (creating ~A)~%" instance (gtype-name (foreign-slot-value class 'g-type-class :type)) *current-creating-object*)
  10   (unless (or *current-creating-object*
  11               *currently-making-object-p*
  12               (gethash (pointer-address instance) *foreign-gobjects-strong*)
  13               (gethash (pointer-address instance) *foreign-gobjects-weak*))
  14     (log-for :subclass "Proceeding with initialization...~%")
  15     (let* ((g-type (foreign-slot-value class 'g-type-class :type))
  16            (type-name (gtype-name g-type))
  17            (lisp-type-info (gethash type-name *registered-types*))
  18            (lisp-class (object-type-class lisp-type-info)))
  19       (make-instance lisp-class :pointer instance))))
  20
  21 (defcallback c-instance-init :void ((instance :pointer) (class :pointer))
  22   (instance-init instance class))
  23
  24 (defcallback c-class-init :void ((class :pointer) (data :pointer))
  25   (class-init class data))
  26
  27 (defun minimum-foreign-integer (type &optional (signed t))
  28   (if signed
  29       (- (ash 1 (1- (* 8 (foreign-type-size type)))))
  30       0))
  31
  32 (defun maximum-foreign-integer (type &optional (signed t))
  33   (if signed
  34       (1- (ash 1 (1- (* 8 (foreign-type-size type)))))
  35       (1- (ash 1 (* 8 (foreign-type-size type))))))
  36
  37 (defun property->param-spec (property)
  38   (destructuring-bind (property-name property-type accessor property-get-fn property-set-fn) property
  39     (declare (ignore accessor))
  40     (let ((property-g-type (gtype property-type))
  41           (flags (append (when property-get-fn (list :readable))
  42                          (when property-set-fn (list :writable)))))
  43       (ev-case (g-type-fundamental property-g-type)
  44         ((gtype +g-type-invalid+) (error "GValue is of invalid type ~A (~A)" property-g-type (gtype-name property-g-type)))
  45         ((gtype +g-type-void+) nil)
  46         ((gtype +g-type-char+) (g-param-spec-char property-name property-name property-name (minimum-foreign-integer :char) (maximum-foreign-integer :char) 0 flags))
  47         ((gtype +g-type-uchar+) (g-param-spec-uchar property-name property-name property-name (minimum-foreign-integer :uchar nil) (maximum-foreign-integer :uchar nil) 0 flags))
  48         ((gtype +g-type-boolean+) (g-param-spec-boolean property-name property-name property-name nil flags))
  49         ((gtype +g-type-int+) (g-param-spec-int property-name property-name property-name (minimum-foreign-integer :int) (maximum-foreign-integer :int) 0 flags))
  50         ((gtype +g-type-uint+) (g-param-spec-uint property-name property-name property-name (minimum-foreign-integer :uint nil) (maximum-foreign-integer :uint nil) 0 flags))
  51         ((gtype +g-type-long+) (g-param-spec-long property-name property-name property-name (minimum-foreign-integer :long) (maximum-foreign-integer :long) 0 flags))
  52         ((gtype +g-type-ulong+) (g-param-spec-ulong property-name property-name property-name (minimum-foreign-integer :ulong nil) (maximum-foreign-integer :ulong nil) 0 flags))
  53         ((gtype +g-type-int64+) (g-param-spec-int64 property-name property-name property-name (minimum-foreign-integer :int64) (maximum-foreign-integer :int64) 0 flags))
  54         ((gtype +g-type-uint64+) (g-param-spec-uint64 property-name property-name property-name (minimum-foreign-integer :uint64 nil) (maximum-foreign-integer :uint64 t) 0 flags))
  55         ((gtype +g-type-enum+) (g-param-spec-enum property-name property-name property-name property-g-type (enum-item-value (first (get-enum-items property-g-type))) flags))
  56         ((gtype +g-type-flags+) (g-param-spec-enum property-name property-name property-name property-g-type (flags-item-value (first (get-flags-items property-g-type))) flags))
  57         ((gtype +g-type-float+) (g-param-spec-float property-name property-name property-name most-negative-single-float most-positive-single-float 0.0 flags))
  58         ((gtype +g-type-double+) (g-param-spec-double property-name property-name property-name most-negative-double-float most-positive-double-float 0.0d0 flags))
  59         ((gtype +g-type-string+) (g-param-spec-string property-name property-name property-name "" flags))
  60         ((gtype +g-type-pointer+) (g-param-spec-pointer property-name property-name property-name flags))
  61         ((gtype +g-type-boxed+) (g-param-spec-boxed property-name property-name property-name property-g-type flags))
  62                                         ;(+g-type-param+ (parse-g-value-param gvalue))
  63         ((gtype +g-type-object+) (g-param-spec-object property-name property-name property-name property-g-type flags))
  64                                         ;(+g-type-interface+ )
  65         (t (error "Unknown type: ~A (~A)" property-g-type (gtype-name property-g-type)))))))
  66
  67 (defun install-properties (class)
  68   (let* ((name (gtype-name (foreign-slot-value class 'g-type-class :type)))
  69          (lisp-type-info (gethash name *registered-types*)))
  70     (iter (for property in (object-type-properties lisp-type-info))
  71           (for param-spec = (property->param-spec property))
  72           (for property-id from 123)
  73           (log-for :subclass "installing property ~A~%" property)
  74           (g-object-class-install-property class property-id param-spec))))
  75
  76 (defun vtable-item->cstruct-item (item)
  77   (if (eq :skip (first item))
  78       (rest item)
  79       (list (first item) :pointer)))
  80
  81 (defstruct vtable-method-info slot-name name return-type args callback-name impl-call)
  82
  83 (defmethod make-load-form ((object vtable-method-info) &optional environment)
  84   (declare (ignore environment))
  85   `(make-vtable-method-info :slot-name ',(vtable-method-info-slot-name object)
  86                             :name ',(vtable-method-info-name object)
  87                             :return-type ',(vtable-method-info-return-type object)
  88                             :args ',(vtable-method-info-args object)
  89                             :callback-name ',(vtable-method-info-callback-name object)))
  90
  91 (defun vtable-methods (iface-name items)
  92   (iter (for item in items)
  93         (when (eq :skip (first item)) (next-iteration))
  94         (destructuring-bind (name (return-type &rest args) &key impl-call) item
  95           (for method-name = (intern (format nil "~A-~A-IMPL" (symbol-name iface-name) (symbol-name name))))
  96           (for callback-name = (intern (format nil "~A-~A-CALLBACK" (symbol-name iface-name) (symbol-name name))))
  97           (collect (make-vtable-method-info :slot-name name
  98                                             :name method-name
  99                                             :return-type return-type
 100                                             :args args
 101                                             :callback-name callback-name
 102                                             :impl-call impl-call)))))
 103
 104 (defvar *vtables* (make-hash-table :test 'equal))
 105
 106 (defstruct vtable-description type-name cstruct-name methods)
 107
 108 (defmacro define-vtable ((type-name name) &body items)
 109   (let ((cstruct-name (intern (format nil "~A-VTABLE" (symbol-name name))))
 110         (methods (vtable-methods name items)))
 111     `(progn
 112        (defcstruct ,cstruct-name ,@(mapcar #'vtable-item->cstruct-item items))
 113        (defctype ,cstruct-name (:struct ,cstruct-name))
 114        (setf (gethash ,type-name *vtables*)
 115              (make-vtable-description :type-name ,type-name
 116                                       :cstruct-name ',cstruct-name
 117                                       :methods (list ,@(mapcar #'make-load-form methods))))
 118        ,@(iter (for method in methods)
 119                (for args =
 120                     (if (vtable-method-info-impl-call method)
 121                         (first (vtable-method-info-impl-call method))
 122                         (mapcar #'first (vtable-method-info-args method))))
 123                (collect `(defgeneric ,(vtable-method-info-name method) (,@args)))
 124                (collect `(glib-defcallback ,(vtable-method-info-callback-name method)
 125                              ,(vtable-method-info-return-type method)
 126                              (,@(vtable-method-info-args method))
 127                            (restart-case
 128                                ,(if (vtable-method-info-impl-call method)
 129                                     `(progn ,@(rest (vtable-method-info-impl-call method)))
 130                                     `(,(vtable-method-info-name method)
 131                                        ,@(mapcar #'first (vtable-method-info-args method))))
 132                              (return-from-interface-method-implementation (v)
 133                                :interactive (lambda () (list (eval (read)))) v))))))))
 134
 135 (defun interface-init (iface data)
 136   (destructuring-bind (class-name interface-name) (prog1 (get-stable-pointer-value data) (free-stable-pointer data))
 137     (declare (ignorable class-name))
 138     (let* ((vtable (gethash interface-name *vtables*))
 139            (vtable-cstruct (vtable-description-cstruct-name vtable)))
 140       (log-for :subclass "interface-init for class ~A and interface ~A~%" class-name interface-name)
 141       (iter (for method in (vtable-description-methods vtable))
 142             (for cb = (get-callback (vtable-method-info-callback-name method)))
 143             (for slot-name = (vtable-method-info-slot-name method))
 144             (log-for :subclass "->setting method ~A to ~A~%" method cb)
 145             (setf (foreign-slot-value iface vtable-cstruct slot-name) cb)))))
 146
 147 (defcallback c-interface-init :void ((iface :pointer) (data :pointer))
 148   (interface-init iface data))
 149
 150 (defun add-interface (name interface)
 151   (let* ((interface-info (list name interface))
 152          (interface-info-ptr (allocate-stable-pointer interface-info)))
 153     (with-foreign-object (info 'g-interface-info)
 154       (setf (foreign-slot-value info 'g-interface-info :interface-init) (callback c-interface-init)
 155             (foreign-slot-value info 'g-interface-info :interface-data) interface-info-ptr)
 156       (g-type-add-interface-static (gtype name) (gtype interface) info))))
 157
 158 (defun add-interfaces (name)
 159   (let* ((lisp-type-info (gethash name *registered-types*))
 160          (interfaces (object-type-interfaces lisp-type-info)))
 161     (iter (for interface in interfaces)
 162           (add-interface name interface))))
 163
 164 (defun class-init (class data)
 165   (declare (ignore data))
 166   (log-for :subclass "class-init for ~A~%" (gtype-name (g-type-from-class class)))
 167   (setf (foreign-slot-value class 'g-object-class :get-property)
 168         (callback c-object-property-get)
 169         (foreign-slot-value class 'g-object-class :set-property)
 170         (callback c-object-property-set))
 171
 172   (install-properties class))
 173
 174 (defun object-property-get (object property-id g-value pspec)
 175   (declare (ignore property-id))
 176   (let* ((lisp-object (or (gethash (pointer-address object) *foreign-gobjects-strong*)
 177                           (gethash (pointer-address object) *foreign-gobjects-weak*)))
 178          (property-name (foreign-slot-value pspec 'g-param-spec :name))
 179          (property-type (foreign-slot-value pspec 'g-param-spec :value-type))
 180          (type-name (gtype-name (foreign-slot-value pspec 'g-param-spec :owner-type)))
 181          (lisp-type-info (gethash type-name *registered-types*))
 182          (property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first))
 183          (property-get-fn (fourth property-info)))
 184     (log-for :subclass "get(~A,'~A')~%" lisp-object property-name)
 185     (let ((value (restart-case
 186                      (funcall property-get-fn lisp-object)
 187                    (return-from-property-getter (value) :interactive (lambda () (format t "Enter new value: ") (list (eval (read)))) value))))
 188       (set-g-value g-value value property-type))))
 189
 190 (defcallback c-object-property-get :void ((object :pointer) (property-id :uint) (value :pointer) (pspec :pointer))
 191   (object-property-get object property-id value pspec))
 192
 193 (defun object-property-set (object property-id value pspec)
 194   (declare (ignore property-id))
 195   (let* ((lisp-object (or (gethash (pointer-address object) *foreign-gobjects-strong*)
 196                           (gethash (pointer-address object) *foreign-gobjects-weak*)))
 197          (property-name (foreign-slot-value pspec 'g-param-spec :name))
 198          (type-name (gtype-name (foreign-slot-value pspec 'g-param-spec :owner-type)))
 199          (lisp-type-info (gethash type-name *registered-types*))
 200          (property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first))
 201          (property-set-fn (fifth property-info))
 202          (new-value (parse-g-value value)))
 203     (log-for :subclass "set(~A,'~A',~A)~%" lisp-object property-name new-value)
 204     (restart-case
 205         (funcall property-set-fn new-value lisp-object)
 206       (return-without-error-from-property-setter () nil))))
 207
 208 (defcallback c-object-property-set :void ((object :pointer) (property-id :uint) (value :pointer) (pspec :pointer))
 209   (object-property-set object property-id value pspec))
 210
 211 (defmacro register-object-type-implementation (name class parent interfaces properties)
 212   (unless (stringp parent)
 213     (setf parent (gtype-name (gtype parent))))
 214   `(progn
 215      (setf (gethash ,name *registered-types*) (make-object-type :name ,name :class ',class :parent ,parent :interfaces ',interfaces :properties ',properties))
 216      (at-init (',class)
 217        (log-for :subclass "Registering GObject type implementation ~A for type ~A~%" ',class ,name)
 218        (with-foreign-object (query 'g-type-query)
 219          (g-type-query (gtype ,parent) query)
 220          (g-type-register-static-simple (gtype ,parent)
 221                                         ,name
 222                                         (foreign-slot-value query 'g-type-query :class-size)
 223                                         (callback c-class-init)
 224                                         (foreign-slot-value query 'g-type-query :instance-size)
 225                                         (callback c-instance-init) nil))
 226        (add-interfaces ,name))
 227      (progn
 228        ,@(iter (for (prop-name prop-type prop-accessor prop-reader prop-writer) in properties)
 229                (declare (ignorable prop-type))
 230                (when prop-reader
 231                  (collect `(defun ,prop-accessor (object) (g-object-call-get-property object ,prop-name))))
 232                (when prop-writer
 233                  (collect `(defun (setf ,prop-accessor) (new-value object) (g-object-call-set-property object ,prop-name new-value))))))
 234      ,name))