(defun instance-init (instance class)
(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*)
+ (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*)
(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))
+ (type-name (gtype-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))))
(defun property->param-spec (property)
(destructuring-bind (property-name property-type accessor property-get-fn property-set-fn) property
(declare (ignore accessor))
- (let ((property-g-type (ensure-g-type property-type))
+ (let ((property-g-type (gtype property-type))
(flags (append (when property-get-fn (list :readable))
(when property-set-fn (list :writable)))))
(ev-case (g-type-fundamental property-g-type)
- (+g-type-invalid+ (error "GValue is of invalid type ~A (~A)" property-g-type (g-type-name property-g-type)))
- (+g-type-void+ nil)
- (+g-type-char+ (g-param-spec-char property-name property-name property-name (minimum-foreign-integer :char) (maximum-foreign-integer :char) 0 flags))
- (+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))
- (+g-type-boolean+ (g-param-spec-boolean property-name property-name property-name nil flags))
- (+g-type-int+ (g-param-spec-int property-name property-name property-name (minimum-foreign-integer :int) (maximum-foreign-integer :int) 0 flags))
- (+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))
- (+g-type-long+ (g-param-spec-long property-name property-name property-name (minimum-foreign-integer :long) (maximum-foreign-integer :long) 0 flags))
- (+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))
- (+g-type-int64+ (g-param-spec-int64 property-name property-name property-name (minimum-foreign-integer :int64) (maximum-foreign-integer :int64) 0 flags))
- (+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))
- (+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))
- (+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))
- (+g-type-float+ (g-param-spec-float property-name property-name property-name most-negative-single-float most-positive-single-float 0.0 flags))
- (+g-type-double+ (g-param-spec-double property-name property-name property-name most-negative-double-float most-positive-double-float 0.0d0 flags))
- (+g-type-string+ (g-param-spec-string property-name property-name property-name "" flags))
- (+g-type-pointer+ (g-param-spec-pointer property-name property-name property-name flags))
- (+g-type-boxed+ (g-param-spec-boxed property-name property-name property-name property-g-type flags))
+ ((gtype +g-type-invalid+) (error "GValue is of invalid type ~A (~A)" property-g-type (gtype-name property-g-type)))
+ ((gtype +g-type-void+) nil)
+ ((gtype +g-type-char+) (g-param-spec-char property-name property-name property-name (minimum-foreign-integer :char) (maximum-foreign-integer :char) 0 flags))
+ ((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))
+ ((gtype +g-type-boolean+) (g-param-spec-boolean property-name property-name property-name nil flags))
+ ((gtype +g-type-int+) (g-param-spec-int property-name property-name property-name (minimum-foreign-integer :int) (maximum-foreign-integer :int) 0 flags))
+ ((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))
+ ((gtype +g-type-long+) (g-param-spec-long property-name property-name property-name (minimum-foreign-integer :long) (maximum-foreign-integer :long) 0 flags))
+ ((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))
+ ((gtype +g-type-int64+) (g-param-spec-int64 property-name property-name property-name (minimum-foreign-integer :int64) (maximum-foreign-integer :int64) 0 flags))
+ ((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))
+ ((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))
+ ((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))
+ ((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))
+ ((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))
+ ((gtype +g-type-string+) (g-param-spec-string property-name property-name property-name "" flags))
+ ((gtype +g-type-pointer+) (g-param-spec-pointer property-name property-name property-name flags))
+ ((gtype +g-type-boxed+) (g-param-spec-boxed property-name property-name property-name property-g-type flags))
;(+g-type-param+ (parse-g-value-param gvalue))
- (+g-type-object+ (g-param-spec-object property-name property-name property-name property-g-type flags))
+ ((gtype +g-type-object+) (g-param-spec-object property-name property-name property-name property-g-type flags))
;(+g-type-interface+ )
- (t (error "Unknown type: ~A (~A)" property-g-type (g-type-name property-g-type)))))))
+ (t (error "Unknown type: ~A (~A)" property-g-type (gtype-name property-g-type)))))))
(defun install-properties (class)
- (let* ((name (g-type-name (foreign-slot-value class 'g-type-class :type)))
+ (let* ((name (gtype-name (foreign-slot-value class 'g-type-class :type)))
(lisp-type-info (gethash name *registered-types*)))
(iter (for property in (object-type-properties lisp-type-info))
(for param-spec = (property->param-spec property))
(rest item)
(list (first item) :pointer)))
-(defstruct vtable-method-info slot-name name return-type args callback-name)
+(defstruct vtable-method-info slot-name name return-type args callback-name impl-call)
(defmethod make-load-form ((object vtable-method-info) &optional environment)
(declare (ignore environment))
(defun vtable-methods (iface-name items)
(iter (for item in items)
(when (eq :skip (first item)) (next-iteration))
- (destructuring-bind (name return-type &rest args) item
+ (destructuring-bind (name (return-type &rest args) &key impl-call) 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)))))
+ :callback-name callback-name
+ :impl-call impl-call)))))
(defvar *vtables* (make-hash-table :test 'equal))
(methods (vtable-methods name items)))
`(progn
(defcstruct ,cstruct-name ,@(mapcar #'vtable-item->cstruct-item items))
+ (defctype ,cstruct-name (:struct ,cstruct-name))
(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)))))
+ (for args =
+ (if (vtable-method-info-impl-call method)
+ (first (vtable-method-info-impl-call method))
+ (mapcar #'first (vtable-method-info-args method))))
+ (collect `(defgeneric ,(vtable-method-info-name method) (,@args)))
(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)))
+ (restart-case
+ ,(if (vtable-method-info-impl-call method)
+ `(progn ,@(rest (vtable-method-info-impl-call method)))
+ `(,(vtable-method-info-name method)
+ ,@(mapcar #'first (vtable-method-info-args method))))
(return-from-interface-method-implementation (v)
:interactive (lambda () (list (eval (read)))) v))))))))
(with-foreign-object (info 'g-interface-info)
(setf (foreign-slot-value info 'g-interface-info :interface-init) (callback c-interface-init)
(foreign-slot-value info 'g-interface-info :interface-data) interface-info-ptr)
- (g-type-add-interface-static (g-type-from-name name) (ensure-g-type interface) info))))
+ (g-type-add-interface-static (gtype name) (gtype interface) info))))
(defun add-interfaces (name)
(let* ((lisp-type-info (gethash name *registered-types*))
(defun class-init (class data)
(declare (ignore data))
- (log-for :subclass "class-init for ~A~%" (g-type-name (g-type-from-class class)))
+ (log-for :subclass "class-init for ~A~%" (gtype-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)
(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)))
+ (type-name (gtype-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)))
(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)))
+ (type-name (gtype-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))
(defmacro register-object-type-implementation (name class parent interfaces properties)
(unless (stringp parent)
- (setf parent (g-type-name (ensure-g-type parent))))
+ (setf parent (gtype-name (gtype parent))))
`(progn
(setf (gethash ,name *registered-types*) (make-object-type :name ,name :class ',class :parent ,parent :interfaces ',interfaces :properties ',properties))
(at-init (',class)
(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)
+ (g-type-query (gtype ,parent) query)
+ (g-type-register-static-simple (gtype ,parent)
,name
(foreign-slot-value query 'g-type-query :class-size)
(callback c-class-init)
(foreign-slot-value query 'g-type-query :instance-size)
(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))
projects / cl-gtk2.git / blobdiff