X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/e2696f4675a74223808187bf8e524a9e20bc5218..43e8a182b5a4b41d3b5bb063cecb15d12ae3964b:/gdk/gdkevents.lisp

diff --git a/gdk/gdkevents.lisp b/gdk/gdkevents.lisp
index b101811..d4ccd58 100644
--- a/gdk/gdkevents.lisp
+++ b/gdk/gdkevents.lisp
@@ -15,18 +15,43 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gdkevents.lisp,v 1.2 2001-05-31 12:36:39 espen Exp $
+;; $Id: gdkevents.lisp,v 1.6 2004-12-20 00:09:57 espen Exp $
 
 (in-package "GDK")
 
 
 (defvar *event-classes* (make-hash-table))
 
-(defun %type-of-event (location)
-  (class-name
-   (gethash
-    (funcall (intern-reader-function 'event-type) location 0)
-    *event-classes*)))
+
+;;;; Metaclass for event classes
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defclass event-class (boxed-class)
+    ((event-type :reader event-class-type)))
+
+  (defmethod validate-superclass ((class event-class) (super standard-class))
+    ;(subtypep (class-name super) 'event)
+    t))
+
+
+(defmethod shared-initialize ((class event-class) names &key name type)
+  (call-next-method)
+  (setf (slot-value class 'event-type) (first type))
+  (setf (gethash (first type) *event-classes*) class)
+  (let ((class-name (or name (class-name class))))
+    (register-type class-name 'event)))
+  
+(let ((reader (reader-function 'event-type)))
+  (defun %event-class (location)
+    (gethash (funcall reader location 0) *event-classes*)))
+
+(defmethod ensure-proxy-instance ((class event-class) location)
+  (declare (ignore class))
+  (let ((class (%event-class location)))
+    (make-instance class :location location)))
+
+
+;;;;
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defclass event (boxed)
@@ -42,63 +67,30 @@   (defclass event (boxed)
       :allocation :alien
       :accessor event-send-event
       :initarg :send-event
-      :type (boolean 8))
-     (%align :allocation :alien :offset 2 :type (unsigned 8)))
-    (:metaclass boxed-class)))
+      :type (boolean 8)))
+    (:metaclass event-class)))
 
 
 (defmethod initialize-instance ((event event) &rest initargs)
   (declare (ignore initargs))
-  (with-slots (location %type) event
-    (setf location (%event-new))
-    (setf %type (event-class-type (class-of event))))
-  (call-next-method))
-
-(deftype-method translate-from-alien
-    event (type-spec location &optional weak-ref)
-  (declare (ignore type-spec))    
-  `(let ((location ,location))
-     (unless (null-pointer-p location)
-       (ensure-proxy-instance (%type-of-event location) location ,weak-ref))))
-
-(defbinding %event-new () pointer)
+  (call-next-method)
+  (setf (slot-value event '%type) (event-class-type (class-of event))))
 
 
-;;;; Metaclass for event classes
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass event-class (proxy-class)
-    ((event-type :reader event-class-type)))
-
-  
-  (defmethod shared-initialize ((class event-class) names
-				&rest initargs &key type)
-    (declare (ignore initargs names))
-    (call-next-method)
-    (setf (slot-value class 'event-type) (first type))
-    (setf (gethash (first type) *event-classes*) class))
-  
-
-  (defmethod validate-superclass
-    ((class event-class) (super pcl::standard-class))
-    (subtypep (class-name super) 'event)))
-
-
-;;;;
-
 (defclass timed-event (event)
   ((time
     :allocation :alien
     :accessor event-time
     :initarg :time
     :type (unsigned 32)))
-  (:metaclass proxy-class))
+  (:metaclass event-class))
   
 (defclass delete-event (event)
   ()
   (:metaclass event-class)
   (:type :delete))
 
+
 (defclass destroy-event (event)
   ()
   (:metaclass event-class)
@@ -125,6 +117,11 @@ (defclass expose-event (event)
     :accessor event-height
     :initarg :height
     :type int)
+   (region
+    :allocation :alien
+    :accessor event-region
+    :initarg :region
+    :type pointer)
    (count
     :allocation :alien
     :accessor event-count
@@ -133,7 +130,7 @@ (defclass expose-event (event)
   (:metaclass event-class)
   (:type :expose))
 
-(defclass motion-notify-event (timed-event)
+(defclass input-event (timed-event)
   ((x
     :allocation :alien
     :accessor event-x
@@ -144,13 +141,21 @@ (defclass motion-notify-event (timed-event)
     :accessor event-y
     :initarg :y
     :type double-float)
+   (axes
+    :allocation :alien
+    :accessor event-axes
+    :initarg :axes
+    :type pointer) ;double-float)
    (state
     :allocation :alien
-    :offset #.(size-of 'pointer)
     :accessor event-state
     :initarg :state
-    :type unsigned-int)
-   (is-hint
+    :type modifier-type))
+  (:metaclass event-class))
+
+
+(defclass motion-notify-event (input-event)
+  ((is-hint
     :allocation :alien
     :accessor event-is-hint
     :initarg :is-hint
@@ -175,24 +180,8 @@ (defclass motion-notify-event (timed-event)
   (:metaclass event-class)
   (:type :motion-notify))
   
-(defclass button-press-event (timed-event)
-  ((x
-    :allocation :alien
-    :accessor event-x
-    :initarg :x
-    :type double-float)
-   (y
-    :allocation :alien
-    :accessor event-y
-    :initarg :y
-    :type double-float)
-   (state
-    :allocation :alien
-    :offset #.(size-of 'pointer)
-    :accessor event-state
-    :initarg :state
-    :type modifier-type)
-   (button
+(defclass button-event (input-event)
+  ((button
     :allocation :alien
     :accessor event-button
     :initarg :button
@@ -212,6 +201,10 @@ (defclass button-press-event (timed-event)
     :accessor event-root-y
     :initarg :root-y
     :type double-float))
+  (:metaclass event-class))
+
+(defclass button-press-event (button-event)
+  ()
   (:metaclass event-class)
   (:type :button-press))
 
@@ -225,33 +218,126 @@ (defclass 3-button-press-event (button-press-event)
   (:metaclass event-class)
   (:type :3button-press))
 
-(defclass button-release-event (button-press-event)
+(defclass button-release-event (button-event)
   ()
   (:metaclass event-class)
   (:type :button-release))
 
-(defclass key-press-event (event)
+
+(defclass key-event (timed-event)
+  ((state
+    :allocation :alien
+    :accessor event-state
+    :initarg :state
+    :type modifier-type)
+   (keyval 
+    :allocation :alien
+    :accessor event-keyval
+    :initarg :keyval
+    :type unsigned-int)
+   (length
+    :allocation :alien
+    :accessor event-length
+    :initarg :length
+    :type unsigned-int)
+   (string
+    :allocation :alien
+    :accessor event-string
+    :initarg :string
+    :type string)
+   (hardware-keycode
+    :allocation :alien
+    :accessor event-hardware-keycode
+    :initarg :hardware-keycode
+    :type (unsigned 16))
+   (group
+    :allocation :alien
+    :accessor event-group
+    :initarg :group
+    :type (unsigned 8)))
+  (:metaclass event-class))
+
+(defclass key-press-event (key-event)
   ()
   (:metaclass event-class)
   (:type :key-press))
 
-(defclass key-release-event (event)
+(defclass key-release-event (key-event)
   ()
   (:metaclass event-class)
   (:type :key-release))
 
-(defclass enter-notify-event (event)
+
+(defclass crossing-event (event)
+  ((subwindow
+    :allocation :alien
+    :accessor event-subwindow
+    :initarg :subwindow
+    :type window)
+   (time
+    :allocation :alien
+    :accessor event-time
+    :initarg :time
+    :type (unsigned 32))
+   (x
+    :allocation :alien
+    :accessor event-x
+    :initarg :x
+    :type double-float)
+   (y
+    :allocation :alien
+    :accessor event-y
+    :initarg :y
+    :type double-float)
+   (root-x
+    :allocation :alien
+    :accessor event-root-x
+    :initarg :root-x
+    :type double-float)
+   (root-y
+    :allocation :alien
+    :accessor event-root-y
+    :initarg :root-y
+    :type double-float)
+   (mode
+    :allocation :alien
+    :accessor event-mode
+    :initarg :mode
+    :type crossing-mode)
+   (detail
+    :allocation :alien
+    :accessor event-detail
+    :initarg :detail
+    :type notify-type)
+   (focus
+    :allocation :alien
+    :accessor event-focus
+    :initarg :focus
+    :type boolean)
+   (state
+    :allocation :alien
+    :accessor event-state
+    :initarg :state
+    :type unsigned-int))
+  (:metaclass event-class))
+
+
+(defclass enter-notify-event (crossing-event)
   ()
   (:metaclass event-class)
   (:type :enter-notify))
 
-(defclass leave-notify-event (event)
+(defclass leave-notify-event (crossing-event)
   ()
   (:metaclass event-class)
   (:type :leave-notify))
 
 (defclass focus-change-event (event)
-  ()
+  ((in
+    :allocation :alien
+    :accessor event-in
+    :initarg :in
+    :type (boolean 16)))
   (:metaclass event-class)
   (:type :focus-change))
 
@@ -309,41 +395,63 @@ (defclass selection-notify-event (event)
   (:metaclass event-class)
   (:type :selection-notify))
 
-(defclass drag-enter-event (event)
+(defclass dnd-event (event)
+  ((context
+    :allocation :alien
+    :accessor event-contex
+    :initarg :context
+    :type drag-context)
+   (time
+    :allocation :alien
+    :accessor event-time
+    :initarg :time
+    :type (unsigned 32))
+   (x-root
+    :allocation :alien
+    :accessor event-x-root
+    :initarg :x-root
+    :type short)
+   (y-root
+    :allocation :alien
+    :accessor event-y-root
+    :initarg :y-root
+    :type short))
+  (:metaclass event-class))
+
+(defclass drag-enter-event (dnd-event)
   ()
   (:metaclass event-class)
   (:type :drag-enter))
 
-(defclass drag-leave-event (event)
+(defclass drag-leave-event (dnd-event)
   ()
   (:metaclass event-class)
   (:type :drag-leave))
 
-(defclass drag-motion-event (event)
+(defclass drag-motion-event (dnd-event)
   ()
   (:metaclass event-class)
   (:type :drag-motion))
 
-(defclass drag-status-event (event)
+(defclass drag-status-event (dnd-event)
   ()
   (:metaclass event-class)
   (:type :drag-status))
 
-(defclass drag-start-event (event)
+(defclass drot-start-event (dnd-event)
   ()
   (:metaclass event-class)
-  (:type :drag-start))
+  (:type :drop-start))
 
-(defclass drag-finished-event (event)
+(defclass drop-finished-event (dnd-event)
   ()
   (:metaclass event-class)
-  (:type :drag-finished))
+  (:type :drop-finished))
 
 (defclass client-event (event)
   ()
   (:metaclass event-class)
-  ;(:type :client-event)
-  )
+  (:type :client-event))
 
 (defclass visibility-notify-event (event)
   ((state
@@ -360,11 +468,87 @@ (defclass no-expose-event (event)
   (:type :no-expose))
   
 (defclass scroll-event (timed-event)
-  ()
+  ((x
+    :allocation :alien
+    :accessor event-x
+    :initarg :x
+    :type double-float)
+   (y
+    :allocation :alien
+    :accessor event-y
+    :initarg :y
+    :type double-float)
+   (state
+    :allocation :alien
+    :accessor event-state
+    :initarg :state
+    :type modifier-type)
+   (direction
+    :allocation :alien
+    :accessor event-direction
+    :initarg :direction
+    :type scroll-direction)
+   (root-x
+    :allocation :alien
+    :accessor event-root-x
+    :initarg :root-x
+    :type double-float)
+   (root-y
+    :allocation :alien
+    :accessor event-root-y
+    :initarg :root-y
+    :type double-float))
   (:metaclass event-class)
   (:type :scroll))
 
-(defclass setting-event (timed-event)
-  ()
+(defclass setting-event (event)
+  ((action
+    :allocation :alien
+    :accessor event-action
+    :initarg :action
+    :type setting-action)
+   (name
+    :allocation :alien
+    :accessor event-name
+    :initarg :name
+    :type string))
   (:metaclass event-class)
   (:type :setting))
+
+(defclass proximity-event (timed-event)
+  ((device
+    :allocation :alien
+    :accessor event-device
+    :initarg :device
+    :type device))
+  (:metaclass event-class))
+
+(defclass proximity-in-event (proximity-event)
+  ()
+  (:metaclass event-class)
+  (:type :proximity-in))
+
+(defclass proximity-out-event (proximity-event)
+  ()
+  (:metaclass event-class)
+  (:type :proximity-out))
+
+(defclass window-state-event (event)
+  ((change-mask
+    :allocation :alien
+    :accessor event-change-mask
+    :initarg :change-mask
+    :type window-state)
+   (new-window-state
+    :allocation :alien
+    :accessor event-new-window-state
+    :initarg :new-window-state
+    :type window-state))
+  (:metaclass event-class)
+  (:type :window-state))
+  
+(defclass owner-change-event (event)
+  ()
+  (:metaclass event-class)
+  (:type :owner-change))
+