(:file "gobject.ffi")
(:file "gobject.type-info")
(:file "gobject.type-info.object")
+ (:file "gobject.type-info.enum")
+ (:file "gobject.type-info.signals")
(:file "gobject.package")
(:file "gobject.structs")
(debugf "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)
- (with-foreign-slots ((class-size instance-size) query g-type-query)
- (g-type-register-static-simple (g-type-from-name ,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)))
+ (g-type-register-static-simple (g-type-from-name ,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)
(unless (or pointer (and (slot-boundp object 'gobject::pointer)
(signal-info (parse-signal-name object-type signal-name)))
(unless signal-info
(error "Signal ~A not found on object ~A" signal-name object))
- (let ((params-count (length (signal-info-param-types object))))
+ (let ((params-count (length (signal-info-param-types signal-info))))
(with-foreign-object (params 'g-value (1+ params-count))
(set-g-value (mem-aref params 'g-value 0) object object-type :zero-g-value t)
(iter (for i from 0 below params-count)
--- /dev/null
+(in-package :gobject.type-info)
+
+(defstruct enum-item
+ "A structure describing a single enumeration item.
+
+See accessor functions:
+@itemize{
+@item{@fun{enum-item-name}}
+@item{@fun{enum-item-value}}
+@item{@fun{enum-item-nick}}
+}"
+ name value nick)
+
+(setf (documentation 'enum-item-name 'function)
+ "The C name of enum item, e.g. \"GTK_WINDOW_TOPLEVEL\".
+@return{a string}")
+
+(setf (documentation 'enum-item-value 'function)
+ "The numeric value of enum item.
+@return{an integer}")
+
+(setf (documentation 'enum-item-nick 'function)
+ "The \"nickname\" of enum item. Nickname is a short name of enum item. E.g., \"toplevel\".
+@return{a string}")
+
+(defun get-enum-items (type)
+ "Gets the list of enum items that belong to GEnum type @code{type}
+@arg[type]{a string or an integer specifying GEnum type}
+@return{a list of @class{enum-item} objects}"
+ (assert (g-type-is-a type +g-type-enum+))
+ (let ((g-class (g-type-class-ref type)))
+ (unwind-protect
+ (loop
+ with n = (foreign-slot-value g-class 'g-enum-class :n-values)
+ with values = (foreign-slot-value g-class 'g-enum-class :values)
+ for i from 0 below n
+ for enum-value = (mem-aref values 'g-enum-value i)
+ collect (make-enum-item
+ :name (foreign-slot-value enum-value 'g-enum-value
+ :name)
+ :value (foreign-slot-value enum-value 'g-enum-value
+ :value)
+ :nick (foreign-slot-value enum-value 'g-enum-value
+ :nick)))
+ (g-type-class-unref g-class))))
+
+(defstruct flags-item
+ "A structure describing a single flags item.
+
+See accessor functions:
+@itemize{
+@item{@fun{flags-item-name}}
+@item{@fun{flags-item-value}}
+@item{@fun{flags-item-nick}}
+}"
+ name value nick)
+
+(setf (documentation 'flags-item-name 'function)
+ "The C name of flags item, e.g. \"GDK_PROPERTY_CHANGE_MASK\".
+@return{a string}")
+
+(setf (documentation 'flags-item-value 'function)
+ "The numeric value of flags item.
+@return{an integer}")
+
+(setf (documentation 'flags-item-nick 'function)
+ "The \"nickname\" of flags item. Nickname is a short name of flags item. E.g., \"property-change-mask\".
+@return{a string}")
+
+(defun get-flags-items (type)
+ "Gets the list of flags items that belong to GFlags type @code{type}
+@arg[type]{a string or an integer specifying GFlags type}
+@return{a list of @class{flags-item} objects}"
+ (assert (g-type-is-a type +g-type-flags+))
+ (let ((g-class (g-type-class-ref type)))
+ (unwind-protect
+ (loop
+ with n = (foreign-slot-value g-class 'g-flags-class :n-values)
+ with values = (foreign-slot-value g-class 'g-flags-class :values)
+ for i from 0 below n
+ for flags-value = (mem-aref values 'g-flags-value i)
+ collect (make-flags-item
+ :name (foreign-slot-value flags-value 'g-flags-value
+ :name)
+ :value (foreign-slot-value flags-value 'g-flags-value
+ :value)
+ :nick (foreign-slot-value flags-value 'g-flags-value
+ :nick)))
+ (g-type-class-unref g-class))))
for i from 0 below (mem-ref n-properties :uint)
for param = (mem-aref params :pointer i)
collect (parse-g-param-spec param))))))
-
-(defstruct enum-item
- "A structure describing a single enumeration item.
-
-See accessor functions:
-@itemize{
-@item{@fun{enum-item-name}}
-@item{@fun{enum-item-value}}
-@item{@fun{enum-item-nick}}
-}"
- name value nick)
-
-(setf (documentation 'enum-item-name 'function)
- "The C name of enum item, e.g. \"GTK_WINDOW_TOPLEVEL\".
-@return{a string}")
-
-(setf (documentation 'enum-item-value 'function)
- "The numeric value of enum item.
-@return{an integer}")
-
-(setf (documentation 'enum-item-nick 'function)
- "The \"nickname\" of enum item. Nickname is a short name of enum item. E.g., \"toplevel\".
-@return{a string}")
-
-(defun get-enum-items (type)
- "Gets the list of enum items that belong to GEnum type @code{type}
-@arg[type]{a string or an integer specifying GEnum type}
-@return{a list of @class{enum-item} objects}"
- (assert (g-type-is-a type +g-type-enum+))
- (let ((g-class (g-type-class-ref type)))
- (unwind-protect
- (loop
- with n = (foreign-slot-value g-class 'g-enum-class :n-values)
- with values = (foreign-slot-value g-class 'g-enum-class :values)
- for i from 0 below n
- for enum-value = (mem-aref values 'g-enum-value i)
- collect (make-enum-item
- :name (foreign-slot-value enum-value 'g-enum-value
- :name)
- :value (foreign-slot-value enum-value 'g-enum-value
- :value)
- :nick (foreign-slot-value enum-value 'g-enum-value
- :nick)))
- (g-type-class-unref g-class))))
-
-(defstruct flags-item
- "A structure describing a single flags item.
-
-See accessor functions:
-@itemize{
-@item{@fun{flags-item-name}}
-@item{@fun{flags-item-value}}
-@item{@fun{flags-item-nick}}
-}"
- name value nick)
-
-(setf (documentation 'flags-item-name 'function)
- "The C name of flags item, e.g. \"GDK_PROPERTY_CHANGE_MASK\".
-@return{a string}")
-
-(setf (documentation 'flags-item-value 'function)
- "The numeric value of flags item.
-@return{an integer}")
-
-(setf (documentation 'flags-item-nick 'function)
- "The \"nickname\" of flags item. Nickname is a short name of flags item. E.g., \"property-change-mask\".
-@return{a string}")
-
-(defun get-flags-items (type)
- "Gets the list of flags items that belong to GFlags type @code{type}
-@arg[type]{a string or an integer specifying GFlags type}
-@return{a list of @class{flags-item} objects}"
- (assert (g-type-is-a type +g-type-flags+))
- (let ((g-class (g-type-class-ref type)))
- (unwind-protect
- (loop
- with n = (foreign-slot-value g-class 'g-flags-class :n-values)
- with values = (foreign-slot-value g-class 'g-flags-class :values)
- for i from 0 below n
- for flags-value = (mem-aref values 'g-flags-value i)
- collect (make-flags-item
- :name (foreign-slot-value flags-value 'g-flags-value
- :name)
- :value (foreign-slot-value flags-value 'g-flags-value
- :value)
- :nick (foreign-slot-value flags-value 'g-flags-value
- :nick)))
- (g-type-class-unref g-class))))
-
-(defstruct signal-info
- id
- name
- owner-type
- flags
- return-type
- param-types
- detail)
-
-(defmethod print-object ((instance signal-info) stream)
- (if *print-readably*
- (call-next-method)
- (print-unreadable-object (instance stream)
- (format stream
- "Signal [#~A] ~A ~A.~A~@[::~A~](~{~A~^, ~})~@[ [~{~A~^, ~}]~]"
- (signal-info-id instance)
- (g-type-string (signal-info-return-type instance))
- (g-type-string (signal-info-owner-type instance))
- (signal-info-name instance)
- (signal-info-detail instance)
- (mapcar #'g-type-string (signal-info-param-types instance))
- (signal-info-flags instance)))))
-
-(defun query-signal-info (signal-id)
- (with-foreign-object (q 'g-signal-query)
- (g-signal-query signal-id q)
- (assert (not (zerop (foreign-slot-value q 'g-signal-query :signal-id))))
- (let ((param-types
- (iter (with param-types = (foreign-slot-value q 'g-signal-query :param-types))
- (for i from 0 below (foreign-slot-value q 'g-signal-query :n-params))
- (for param-type = (mem-aref param-types '(g-type-designator :mangled-p t) i))
- (collect param-type))))
- (make-signal-info :id signal-id
- :name (foreign-slot-value q 'g-signal-query :signal-name)
- :owner-type (foreign-slot-value q 'g-signal-query :owner-type)
- :flags (foreign-slot-value q 'g-signal-query :signal-flags)
- :return-type (foreign-slot-value q 'g-signal-query :return-type)
- :param-types param-types))))
-
-(defun parse-signal-name (owner-type signal-name)
- (with-foreign-objects ((signal-id :uint) (detail 'glib:g-quark))
- (when (g-signal-parse-name signal-name owner-type signal-id detail t)
- (let ((signal-info (query-signal-info (mem-ref signal-id :uint))))
- (setf (signal-info-detail signal-info) (mem-ref detail 'g-quark))
- signal-info))))
-
-(defun type-signals (type &key include-inherited)
- (unless (= (g-type-numeric type) +g-type-invalid+)
- (let ((signals (with-foreign-object (n-ids :uint)
- (with-unwind (ids (g-signal-list-ids type n-ids) g-free)
- (iter (for i from 0 below (mem-ref n-ids :uint))
- (collect (query-signal-info (mem-aref ids :uint i))))))))
- (if include-inherited
- (nconc (type-signals (g-type-parent type) :include-inherited t)
- (iter (for interface in (g-type-interfaces type))
- (nconcing (type-signals interface :include-inherited t)))
- signals)
- signals))))
--- /dev/null
+(in-package :gobject.type-info)
+
+(defstruct signal-info
+ id
+ name
+ owner-type
+ flags
+ return-type
+ param-types
+ detail)
+
+(defmethod print-object ((instance signal-info) stream)
+ (if *print-readably*
+ (call-next-method)
+ (print-unreadable-object (instance stream)
+ (format stream
+ "Signal [#~A] ~A ~A.~A~@[::~A~](~{~A~^, ~})~@[ [~{~A~^, ~}]~]"
+ (signal-info-id instance)
+ (g-type-string (signal-info-return-type instance))
+ (g-type-string (signal-info-owner-type instance))
+ (signal-info-name instance)
+ (signal-info-detail instance)
+ (mapcar #'g-type-string (signal-info-param-types instance))
+ (signal-info-flags instance)))))
+
+(defun query-signal-info (signal-id)
+ (with-foreign-object (q 'g-signal-query)
+ (g-signal-query signal-id q)
+ (assert (not (zerop (foreign-slot-value q 'g-signal-query :signal-id))))
+ (let ((param-types
+ (iter (with param-types = (foreign-slot-value q 'g-signal-query :param-types))
+ (for i from 0 below (foreign-slot-value q 'g-signal-query :n-params))
+ (for param-type = (mem-aref param-types '(g-type-designator :mangled-p t) i))
+ (collect param-type))))
+ (make-signal-info :id signal-id
+ :name (foreign-slot-value q 'g-signal-query :signal-name)
+ :owner-type (foreign-slot-value q 'g-signal-query :owner-type)
+ :flags (foreign-slot-value q 'g-signal-query :signal-flags)
+ :return-type (foreign-slot-value q 'g-signal-query :return-type)
+ :param-types param-types))))
+
+(defun parse-signal-name (owner-type signal-name)
+ (with-foreign-objects ((signal-id :uint) (detail 'glib:g-quark))
+ (when (g-signal-parse-name signal-name owner-type signal-id detail t)
+ (let ((signal-info (query-signal-info (mem-ref signal-id :uint))))
+ (setf (signal-info-detail signal-info) (mem-ref detail 'g-quark))
+ signal-info))))
+
+(defun type-signals (type &key include-inherited)
+ (unless (= (g-type-numeric type) +g-type-invalid+)
+ (let ((signals (with-foreign-object (n-ids :uint)
+ (with-unwind (ids (g-signal-list-ids type n-ids) g-free)
+ (iter (for i from 0 below (mem-ref n-ids :uint))
+ (collect (query-signal-info (mem-aref ids :uint i))))))))
+ (if include-inherited
+ (nconc (type-signals (g-type-parent type) :include-inherited t)
+ (iter (for interface in (g-type-interfaces type))
+ (nconcing (type-signals interface :include-inherited t)))
+ signals)
+ signals))))
projects / cl-gtk2.git / commitdiff