From afef4514bd3b67114bc3f62c3109b14a4334142b Mon Sep 17 00:00:00 2001 From: Dmitry Kalyanov Date: Sun, 12 Jul 2009 14:18:04 +0400 Subject: [PATCH] Separate enum and signals from gobject.type-info.object; fix emit-signals; fix style-warning in register-object-type-implementation --- glib/cl-gtk2-glib.asd | 2 + glib/gobject.foreign-gobject-subclassing.lisp | 13 +-- glib/gobject.signals.lisp | 2 +- glib/gobject.type-info.enum.lisp | 89 +++++++++++++++ glib/gobject.type-info.object.lisp | 147 ------------------------- glib/gobject.type-info.signals.lisp | 60 ++++++++++ 6 files changed, 158 insertions(+), 155 deletions(-) create mode 100644 glib/gobject.type-info.enum.lisp create mode 100644 glib/gobject.type-info.signals.lisp diff --git a/glib/cl-gtk2-glib.asd b/glib/cl-gtk2-glib.asd index aedb4bc..810050d 100644 --- a/glib/cl-gtk2-glib.asd +++ b/glib/cl-gtk2-glib.asd @@ -15,6 +15,8 @@ (: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") diff --git a/glib/gobject.foreign-gobject-subclassing.lisp b/glib/gobject.foreign-gobject-subclassing.lisp index d41d5bb..039203d 100644 --- a/glib/gobject.foreign-gobject-subclassing.lisp +++ b/glib/gobject.foreign-gobject-subclassing.lisp @@ -202,13 +202,12 @@ (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) diff --git a/glib/gobject.signals.lisp b/glib/gobject.signals.lisp index c2a2a29..d4a46ef 100644 --- a/glib/gobject.signals.lisp +++ b/glib/gobject.signals.lisp @@ -10,7 +10,7 @@ (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) diff --git a/glib/gobject.type-info.enum.lisp b/glib/gobject.type-info.enum.lisp new file mode 100644 index 0000000..7764c18 --- /dev/null +++ b/glib/gobject.type-info.enum.lisp @@ -0,0 +1,89 @@ +(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)))) diff --git a/glib/gobject.type-info.object.lisp b/glib/gobject.type-info.object.lisp index 166b006..1637b01 100644 --- a/glib/gobject.type-info.object.lisp +++ b/glib/gobject.type-info.object.lisp @@ -103,150 +103,3 @@ See accessor functions: 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)))) diff --git a/glib/gobject.type-info.signals.lisp b/glib/gobject.type-info.signals.lisp new file mode 100644 index 0000000..b75be0d --- /dev/null +++ b/glib/gobject.type-info.signals.lisp @@ -0,0 +1,60 @@ +(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)))) -- 1.7.10.4