- (when (events-pending-p)
- (main-iteration nil)
- (main-iterate-all)))
-
-; (define-foreign ("gtk_timeout_add_full" timeout-add)
-; (interval function) unsigned-int
-; (interval (unsigned 32))
-; (0 unsigned-long)
-; (*callback-marshal* pointer)
-; ((register-callback-function function) unsigned-long)
-; (*destroy-marshal* pointer))
-
-; (define-foreign timeout-remove () nil
-; (timeout-handler-id unsigned-int))
-
-; (define-foreign ("gtk_idle_add_full" idle-add)
-; (function &optional (priority 200)) unsigned-int
-; (priority int)
-; (0 unsigned-long)
-; (*callback-marshal* pointer)
-; ((register-callback-function function) unsigned-long)
-; (*destroy-marshal* pointer))
-
-; (define-foreign idle-remove () nil
-; (idle-handler-id unsigned-int))
-
-
-(system:add-fd-handler (gdk:event-poll-fd) :input #'main-iterate-all)
-(setq lisp::*periodic-polling-function* #'main-iterate-all)
-(setq lisp::*max-event-to-sec* 0)
-(setq lisp::*max-event-to-usec* 1000)
-
-
-
-;;;; Metaclass used for subclasses of object
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass object-class (gobject-class)))
-
-
-(defmethod validate-superclass ((class object-class)
- (super pcl::standard-class))
- (subtypep (class-name super) 'object))
-
-
-;;;; Metaclasses used for widgets and containers
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass widget-class (object-class))
-
- (defclass container-class (widget-class)
- (child-class)))
-
-
-(defvar *child-to-container-class-mappings* (make-hash-table))
-
-(defmethod shared-initialize ((class container-class) names
- &rest initargs &key name child-class)
- (declare (ignore initargs))
- (call-next-method)
- (with-slots ((child-class-slot child-class)) class
- (setf
- child-class-slot
- (or
- (first child-class)
- (intern (format nil "~A-CHILD" (or name (class-name class)))))
- (gethash child-class-slot *child-to-container-class-mappings*)
- class)))
-
-
-(defmethod validate-superclass ((class widget-class)
- (super pcl::standard-class))
- (subtypep (class-name super) 'widget))
-
-(defmethod validate-superclass ((class container-class)
- (super pcl::standard-class))
- (subtypep (class-name super) 'container))
-