(defstruct object-type name class parent interfaces properties)
-(defvar *lisp-objects-references* (make-hash-table :test 'equal))
-
-(defun object-toggle-pointer (data object is-last-ref)
- (declare (ignore data))
- (debugf "Toggling pointer on ~a (~A) to being ~A~%" object (gethash (pointer-address object) *lisp-objects-references*) (if is-last-ref "last ref" "not last ref"))
- (if is-last-ref
- (remhash (pointer-address object) *lisp-objects-references*)
- (setf (gethash (pointer-address object) *lisp-objects-references*) (gethash (pointer-address object) *foreign-gobjects*))))
-
(defun instance-init (instance class)
- (debugf "Initializing instance ~A for type ~A (creating ~A)~%" instance (g-type-name (foreign-slot-value class 'g-type-class :type)) *current-creating-object*)
- (unless (gethash (pointer-address instance) *lisp-objects-pointers*)
- (debugf " Proceeding with initialization...")
- (setf (gethash (pointer-address instance) *lisp-objects-pointers*) t
- (gethash (pointer-address instance) *lisp-objects-references*)
- (or *current-creating-object*
- (let* ((g-type (foreign-slot-value class 'g-type-class :type))
- (type-name (g-type-name g-type))
- (lisp-type-info (gethash type-name *registered-types*))
- (lisp-class (object-type-class lisp-type-info)))
- (make-instance lisp-class :pointer instance))))
- (g-object-add-toggle-ref instance (callback c-object-toggle-pointer) (null-pointer))
- (g-object-unref instance)))
-
-(defcallback c-object-toggle-pointer :void ((data :pointer) (object :pointer) (is-last-ref :boolean))
- (object-toggle-pointer data object is-last-ref))
+ (log-for :subclass "(instance-init ~A ~A)~%" instance class)
+ (log-for :subclass "Initializing instance ~A for type ~A (creating ~A)~%" instance (g-type-name (foreign-slot-value class 'g-type-class :type)) *current-creating-object*)
+ (unless (or *current-creating-object*
+ *currently-making-object-p*
+ (gethash (pointer-address instance) *foreign-gobjects-strong*)
+ (gethash (pointer-address instance) *foreign-gobjects-weak*))
+ (log-for :subclass "Proceeding with initialization...~%")
+ (let* ((g-type (foreign-slot-value class 'g-type-class :type))
+ (type-name (g-type-name g-type))
+ (lisp-type-info (gethash type-name *registered-types*))
+ (lisp-class (object-type-class lisp-type-info)))
+ (make-instance lisp-class :pointer instance))))
(defcallback c-instance-init :void ((instance :pointer) (class :pointer))
(instance-init instance class))
(iter (for property in (object-type-properties lisp-type-info))
(for param-spec = (property->param-spec property))
(for property-id from 123)
- (debugf "installing property ~A~%" property)
+ (log-for :subclass "installing property ~A~%" property)
(g-object-class-install-property class property-id param-spec))))
(defun vtable-item->cstruct-item (item)
(rest item)
(list (first item) :pointer)))
-(defstruct vtable-method-info name return-type args callback-name)
+(defstruct vtable-method-info slot-name name return-type args callback-name)
(defmethod make-load-form ((object vtable-method-info) &optional environment)
(declare (ignore environment))
- `(make-vtable-method-info :name ',(vtable-method-info-name object)
+ `(make-vtable-method-info :slot-name ',(vtable-method-info-slot-name object)
+ :name ',(vtable-method-info-name object)
:return-type ',(vtable-method-info-return-type object)
:args ',(vtable-method-info-args object)
:callback-name ',(vtable-method-info-callback-name object)))
-(defun vtable-methods (items)
+(defun vtable-methods (iface-name items)
(iter (for item in items)
(when (eq :skip (first item)) (next-iteration))
- (destructuring-bind (name callback-name return-type &rest args) item
- (collect (make-vtable-method-info :name name :return-type return-type :args args :callback-name callback-name)))))
+ (destructuring-bind (name return-type &rest args) item
+ (for method-name = (intern (format nil "~A-~A-IMPL" (symbol-name iface-name) (symbol-name name))))
+ (for callback-name = (intern (format nil "~A-~A-CALLBACK" (symbol-name iface-name) (symbol-name name))))
+ (collect (make-vtable-method-info :slot-name name
+ :name method-name
+ :return-type return-type
+ :args args
+ :callback-name callback-name)))))
(defvar *vtables* (make-hash-table :test 'equal))
(defstruct vtable-description type-name cstruct-name methods)
-(defmacro define-vtable ((type-name cstruct-name) &body items)
- `(progn
- (defcstruct ,cstruct-name ,@(mapcar #'vtable-item->cstruct-item items))
- (setf (gethash ,type-name *vtables*)
- (make-vtable-description :type-name ,type-name :cstruct-name ',cstruct-name :methods (list ,@(mapcar #'make-load-form (vtable-methods items)))))
- ,@(iter (for method in (vtable-methods items))
- (collect `(defgeneric ,(vtable-method-info-name method) (,@(mapcar #'first (vtable-method-info-args method)))))
- (collect `(defcallback ,(vtable-method-info-callback-name method) ,(vtable-method-info-return-type method)
- (,@(vtable-method-info-args method))
- (restart-case
- (,(vtable-method-info-name method) ,@(mapcar #'first (vtable-method-info-args method)))
- (return-from-interface-method-implementation (v) :interactive (lambda () (list (eval (read)))) v)))))))
+(defmacro define-vtable ((type-name name) &body items)
+ (let ((cstruct-name (intern (format nil "~A-VTABLE" (symbol-name name))))
+ (methods (vtable-methods name items)))
+ `(progn
+ (defcstruct ,cstruct-name ,@(mapcar #'vtable-item->cstruct-item items))
+ (setf (gethash ,type-name *vtables*)
+ (make-vtable-description :type-name ,type-name
+ :cstruct-name ',cstruct-name
+ :methods (list ,@(mapcar #'make-load-form methods))))
+ ,@(iter (for method in methods)
+ (collect `(defgeneric ,(vtable-method-info-name method)
+ (,@(mapcar #'first (vtable-method-info-args method)))))
+ (collect `(glib-defcallback ,(vtable-method-info-callback-name method)
+ ,(vtable-method-info-return-type method)
+ (,@(vtable-method-info-args method))
+ (restart-case
+ (,(vtable-method-info-name method) ,@(mapcar #'first (vtable-method-info-args method)))
+ (return-from-interface-method-implementation (v)
+ :interactive (lambda () (list (eval (read)))) v))))))))
(defun interface-init (iface data)
(destructuring-bind (class-name interface-name) (prog1 (get-stable-pointer-value data) (free-stable-pointer data))
+ (declare (ignorable class-name))
(let* ((vtable (gethash interface-name *vtables*))
(vtable-cstruct (vtable-description-cstruct-name vtable)))
- (debugf "interface-init for class ~A and interface ~A~%" class-name interface-name)
+ (log-for :subclass "interface-init for class ~A and interface ~A~%" class-name interface-name)
(iter (for method in (vtable-description-methods vtable))
- (setf (foreign-slot-value iface vtable-cstruct (vtable-method-info-name method)) (get-callback (vtable-method-info-callback-name method)))))))
+ (for cb = (get-callback (vtable-method-info-callback-name method)))
+ (for slot-name = (vtable-method-info-slot-name method))
+ (log-for :subclass "->setting method ~A to ~A~%" method cb)
+ (setf (foreign-slot-value iface vtable-cstruct slot-name) cb)))))
(defcallback c-interface-init :void ((iface :pointer) (data :pointer))
(interface-init iface data))
(defun class-init (class data)
(declare (ignore data))
- (debugf "class-init for ~A~%" (g-type-name (g-type-from-class class)))
+ (log-for :subclass "class-init for ~A~%" (g-type-name (g-type-from-class class)))
(setf (foreign-slot-value class 'g-object-class :get-property)
(callback c-object-property-get)
(foreign-slot-value class 'g-object-class :set-property)
(defun object-property-get (object property-id g-value pspec)
(declare (ignore property-id))
- (let* ((lisp-object (gethash (pointer-address object) *lisp-objects-references*))
+ (let* ((lisp-object (or (gethash (pointer-address object) *foreign-gobjects-strong*)
+ (gethash (pointer-address object) *foreign-gobjects-weak*)))
(property-name (foreign-slot-value pspec 'g-param-spec :name))
(property-type (foreign-slot-value pspec 'g-param-spec :value-type))
(type-name (g-type-name (foreign-slot-value pspec 'g-param-spec :owner-type)))
(lisp-type-info (gethash type-name *registered-types*))
(property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first))
(property-get-fn (fourth property-info)))
- (debugf "get(~A,'~A')~%" lisp-object property-name)
+ (log-for :subclass "get(~A,'~A')~%" lisp-object property-name)
(let ((value (restart-case
(funcall property-get-fn lisp-object)
- (return-from-property-getter (value) :interactive (lambda () (debugf "Enter new value: ") (list (eval (read)))) value))))
+ (return-from-property-getter (value) :interactive (lambda () (format t "Enter new value: ") (list (eval (read)))) value))))
(set-g-value g-value value property-type))))
(defcallback c-object-property-get :void ((object :pointer) (property-id :uint) (value :pointer) (pspec :pointer))
(defun object-property-set (object property-id value pspec)
(declare (ignore property-id))
- (let* ((lisp-object (gethash (pointer-address object) *lisp-objects-references*))
+ (let* ((lisp-object (or (gethash (pointer-address object) *foreign-gobjects-strong*)
+ (gethash (pointer-address object) *foreign-gobjects-weak*)))
(property-name (foreign-slot-value pspec 'g-param-spec :name))
(type-name (g-type-name (foreign-slot-value pspec 'g-param-spec :owner-type)))
(lisp-type-info (gethash type-name *registered-types*))
(property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first))
(property-set-fn (fifth property-info))
(new-value (parse-g-value value)))
- (debugf "set(~A,'~A',~A)~%" lisp-object property-name new-value)
+ (log-for :subclass "set(~A,'~A',~A)~%" lisp-object property-name new-value)
(restart-case
(funcall property-set-fn new-value lisp-object)
(return-without-error-from-property-setter () nil))))
`(progn
(setf (gethash ,name *registered-types*) (make-object-type :name ,name :class ',class :parent ,parent :interfaces ',interfaces :properties ',properties))
(at-init (',class)
- (debugf "Registering GObject type implementation ~A for type ~A~%" ',class ,name)
+ (log-for :subclass "Registering GObject type implementation ~A for type ~A~%" ',class ,name)
(with-foreign-object (query 'g-type-query)
(g-type-query (g-type-from-name ,parent) query)
(g-type-register-static-simple (g-type-from-name ,parent)
(callback c-instance-init) nil))
(add-interfaces ,name))
(defmethod initialize-instance :before ((object ,class) &key pointer)
+ (log-for :subclass "(initialize-instance ~A :pointer ~A) :before~%" object pointer)
(unless (or pointer (and (slot-boundp object 'gobject::pointer)
(gobject::pointer object)))
+ (log-for :subclass "calling g-object-constructor~%")
(setf (gobject::pointer object) (gobject::g-object-call-constructor ,name nil nil)
(gobject::g-object-has-reference object) t)))
(progn
,@(iter (for (prop-name prop-type prop-accessor prop-reader prop-writer) in properties)
+ (declare (ignorable prop-type))
(when prop-reader
(collect `(defun ,prop-accessor (object) (g-object-call-get-property object ,prop-name))))
(when prop-writer
projects / cl-gtk2.git / blobdiff