X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/fb37007601c271878ec48d5714d7dce76518fafc..72d9260f8258b525339c7241da0631ceaf9f3842:/gtk/gtkobject.lisp diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp index 9a31981..d9bae51 100644 --- a/gtk/gtkobject.lisp +++ b/gtk/gtkobject.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtkobject.lisp,v 1.40 2007-03-12 12:59:22 espen Exp $ +;; $Id: gtkobject.lisp,v 1.49 2008-10-09 18:45:01 espen Exp $ (in-package "GTK") @@ -29,14 +29,12 @@ (in-package "GTK") ;;;; Superclass for the gtk class hierarchy (eval-when (:compile-toplevel :load-toplevel :execute) - (init-types-in-library - #.(concatenate 'string (pkg-config:pkg-variable "gtk+-2.0" "libdir") - "/libgtk-x11-2.0." asdf:*dso-extension*)) + (init-types-in-library gtk "libgtk-2.0")) - (defclass %object (gobject) - () - (:metaclass gobject-class) - (:gtype |gtk_object_get_type|))) +(defclass %object (initially-unowned) + () + (:metaclass gobject-class) + (:gtype |gtk_object_get_type|)) (defmethod initialize-instance ((object %object) &rest initargs &key signal) @@ -45,19 +43,24 @@ (defmethod initialize-instance ((object %object) &rest initargs &key signal) (dolist (signal-definition (get-all initargs :signal)) (apply #'signal-connect object signal-definition))) -(defmethod initialize-instance :around ((object %object) &rest initargs) - (declare (ignore initargs)) - (call-next-method) - ;; Add a temorary reference which will be removed when the object is - ;; sinked - (funcall (reference-function '%object) (foreign-location object)) - (%object-sink object)) - -(defbinding %object-sink () nil - (object %object)) +#?-(pkg-exists-p "glib-2.0" :atleast-version "2.10.0") +(progn + (defmethod initialize-instance :around ((object %object) &rest initargs) + (declare (ignore initargs)) + (call-next-method) + ;; Add a temorary reference which will be removed when the object is + ;; sinked + (funcall (reference-function '%object) (foreign-location object)) + (%object-sink object)) + + (defbinding %object-sink () nil + (object %object))) ;;;; Main loop and event handling +(defparameter *reentrant-main-iteration* t) +(defvar *running-main-iteration* nil) + (defbinding events-pending-p () boolean) (defbinding get-current-event () gdk:event) @@ -76,12 +79,27 @@ (defbinding main-iteration-do (&optional (blocking t)) boolean (defun main-iterate-all (&rest args) (declare (ignore args)) - (loop - while (events-pending-p) - do (main-iteration-do nil)) + (unless (and (not *reentrant-main-iteration*) *running-main-iteration*) + (let ((*running-main-iteration* t)) + (loop + while (events-pending-p) + do (main-iteration-do nil)))) #+clisp 0) +(define-callback fd-source-callback-marshal nil + ((callback-id unsigned-int) (fd unsigned-int)) + (glib::invoke-source-callback callback-id fd)) + +(defbinding (input-add "gtk_input_add_full") (fd condition function) unsigned-int + (fd unsigned-int) + (condition gdk:input-condition) + (fd-source-callback-marshal callback) + (nil null) + ((register-callback-function function) unsigned-long) + (user-data-destroy-callback callback)) + + ;;;; Metaclass for child classes (defvar *container-to-child-class-mappings* (make-hash-table)) @@ -170,7 +188,7 @@ (defmethod compute-slot-writer-function ((slotd effective-child-slot-definition) value)))) -(defmethod add-reader-method ((class container-child-class) generic-function slot-name #?(sbcl>= 1 0 2)slot-documentation) +(defmethod add-reader-method ((class container-child-class) generic-function slot-name #?(sbcl>= 1 0 2)slot-documentation #?(sbcl>= 1 0 14)source-location) (add-method generic-function (make-instance 'standard-method @@ -181,7 +199,7 @@ (defmethod add-reader-method ((class container-child-class) generic-function slo (declare (ignore next-methods)) (child-property-value (first args) slot-name))))) -(defmethod add-writer-method ((class container-child-class) generic-function slot-name #?(sbcl>= 1 0 2)slot-documentation) +(defmethod add-writer-method ((class container-child-class) generic-function slot-name #?(sbcl>= 1 0 2)slot-documentation #?(sbcl>= 1 0 14)source-location) (add-method generic-function (make-instance 'standard-method @@ -210,12 +228,18 @@ (defbinding %container-class-list-child-properties () pointer (class pointer) (n-properties unsigned-int :out)) -(defun query-container-class-child-properties (type-number) +(defun query-container-class-child-properties (type-number &optional owner-only-p) (let ((class (type-class-ref type-number))) (multiple-value-bind (array length) (%container-class-list-child-properties class) (unwind-protect - (map-c-vector 'list #'identity array 'param length) + (let ((properties (map-c-vector 'list #'identity array 'param length))) + (if owner-only-p + (delete-if + #'(lambda (property) + (not (eql (slot-value property 'glib::owner-type) type-number))) + properties) + properties)) (deallocate-memory array))))) (defun default-container-child-name (container-class) @@ -229,13 +253,37 @@ (defun expand-container-type (type forward-p options) (expand-gobject-type type t options) `(progn ,(expand-gobject-type type nil options) - (defclass ,child-class (,(default-container-child-name super)) - ,(slot-definitions child-class - (query-container-class-child-properties type) nil) - (:metaclass container-child-class) - (:container ,class)))))) - -(defun container-child-class (container-class) - (gethash container-class *container-to-child-class-mappings*)) + ,(let ((child-properties (query-container-class-child-properties type t))) + (when child-properties + `(defclass ,child-class (,(default-container-child-name super)) + ,(slot-definitions child-class child-properties nil) + (:metaclass container-child-class) + (:container ,class)))))))) + +(defun container-dependencies (type options) + (delete-duplicates + (append + (gobject-dependencies type options) + (mapcar #'param-value-type (query-container-class-child-properties type))))) + +(register-derivable-type 'container "GtkContainer" 'expand-container-type 'container-dependencies) + + +(defmacro define-callback-setter (name arg return-type &rest rest-args) + (let ((callback (gensym))) + (if arg + `(progn + (define-callback-marshal ,callback ,return-type + ,(cons arg rest-args)) + (defbinding ,name () nil + ,arg + (,callback callback) + (function user-callback) + (user-data-destroy-callback callback))) + `(progn + (define-callback-marshal ,callback ,return-type ,rest-args) + (defbinding ,name () nil + (,callback callback) + (function user-callback) + (user-data-destroy-callback callback)))))) -(register-derivable-type 'container "GtkContainer" 'expand-container-type 'gobject-dependencies)