chiark / gitweb /
Changes necessary to allow saving of core images with clg.
[clg] / gdk / gdktypes.lisp
index 447b611decc2ae241bda0e8d0f3b7eabceb47d30..6cfbc7fb6b1d15a4cc1fee397cd2fc28a82220ad 100644 (file)
@@ -1,5 +1,5 @@
 ;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 1999-2000 Espen S. Johnsen <esj@stud.cs.uit.no>
+;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
 ;; 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: gdktypes.lisp,v 1.2 2001-02-11 20:28:07 espen Exp $
+;; $Id: gdktypes.lisp,v 1.16 2005-03-06 17:26:22 espen Exp $
 
 (in-package "GDK")
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (init-types-in-library #.(concatenate 'string
+                           (pkg-config:pkg-variable "gtk+-2.0" "libdir")
+                           "/libgdk-x11-2.0.so") :prefix ("gdk_" "_gdk_"))
+  (init-types-in-library #.(concatenate 'string
+                           (pkg-config:pkg-variable "gtk+-2.0" "libdir")
+                           "/libgdk_pixbuf-2.0.so") :prefix "gdk_"))
 
-(defclass color (alien-structure)
+
+(defclass color (boxed)
   ((pixel
     :allocation :alien
     :type unsigned-long)
@@ -30,404 +38,226 @@ (defclass color (alien-structure)
     :type unsigned-short)
    (green
     :allocation :alien
-    :accessor color-grenn
+    :accessor color-green
     :type unsigned-short)
    (blue
     :allocation :alien
     :accessor color-blue
     :type unsigned-short))
-  (:metaclass alien-class)
-  (:alien-name "GdkColor"))
-
-
-(defclass visual (static-structure)
-  ()
-  (:metaclass alien-class)
-  (:alien-name "GdkVisual"))
-
-
-(defclass colormap (gobject)
-  ()
-  (:metaclass gobject-class)
-  (:alien-name "GdkColormap"))
-
-
-(defclass drawable (gobject)
-  ()
-  (:metaclass gobject-class)
-  (:alien-name "GdkDrawable"))
-
-
-(defclass window (drawable)
-  ()
-  (:metaclass gobject-class)
-  (:alien-name "GdkWindow")
-  (:type-init "gdk_window_object_get_type"))
-
-
-(defclass pixmap (drawable)
-  ()
-  (:metaclass gobject-class)
-  (:alien-name "GdkPixmap"))
-
-;; Bitmaps is not defined as a propper type in gdk, only as an alias for
-;; GdkDrawable, so we have to define it this way as a workaround
-(defclass bitmap (alien-object)
-  ()
-  (:metaclass alien-class))
-
-
-; (defclass geometry (alien-structure)
-;   ((min-width
-;     :allocation :alien
-;     :accessor geometry-min-width
-;     :initarg :min-width
-;     :type int)  
-;    (min-height
-;     :allocation :alien
-;     :accessor geometry-min-height
-;     :initarg :min-heigth
-;     :type int)
-;    (max-width
-;     :allocation :alien
-;     :accessor geometry-max-width
-;     :initarg :max-width
-;     :type int)  
-;    (max-height
-;     :allocation :alien
-;     :accessor geometry-max-height
-;     :initarg :max-heigth
-;     :type int)
-;    (base-width
-;     :allocation :alien
-;     :accessor geometry-base-width
-;     :initarg :base-width
-;     :type int)
-;    (base-height
-;     :allocation :alien
-;     :accessor geometry-base-height
-;     :initarg :base-heigth
-;     :type int)
-;    (width-inc
-;     :allocation :alien
-;     :accessor geometry-width-inc
-;     :initarg :width-inc
-;     :type int)   
-;    (height-inc
-;     :allocation :alien
-;     :accessor geometry-height-inc
-;     :initarg :heigth-inc
-;     :type int)
-;    (min-aspect
-;     :allocation :alien
-;     :accessor geometry-min-aspect
-;     :initarg :min-aspect
-;     :type double-float)
-;    (max-aspect
-;     :allocation :alien
-;     :accessor geometry-max-aspect
-;     :initarg :max-aspect
-;     :type double-float))
-;   (:metaclass alien-class))
-  
-
-(defclass image (gobject)
-  ()
-  (:metaclass gobject-class)
-  (:alien-name "GdkImage"))
-
-
-(defclass gc (gobject)
-  ()
-  (:metaclass gobject-class)
-  (:alien-name "GdkGC"))
-
-
-(defclass font (alien-object)
-  ()
-  (:metaclass alien-class)
-  (:alien-name "GdkFont"))
-
-
-(defclass cursor (alien-object)
-  ((type
-    :allocation :alien
-    :accessor cursor-type
-    :initarg :type
-    :type cursor-type))
-  (:metaclass alien-class))
-
-
-(defclass drag-context (gobject)
-  ()
-  (:metaclass gobject-class)
-  (:alien-name "GdkDragContext"))
+  (:metaclass boxed-class))
 
 
-(defclass device (alien-structure)
-  ()
-  (:metaclass alien-class))
+(deftype point () '(vector int 2))
+(deftype segment () '(vector int 4))
+(deftype trapezoid () '(vector double-float 6))
+(deftype atom () 'unsigned-int)
 
-(defclass event (alien-structure)
-  ((window
-    :allocation :alien
-    :offset #.(size-of 'pointer)
-    :accessor event-window
-    :initarg :window
-    :type window)
-   (send-event
-    :allocation :alien
-    :accessor event-send-event
-    :initarg :send-event
-    :type (boolean 8))
-   (%align :allocation :alien :offset 2 :type (unsigned 8)))
-  (:metaclass alien-class)
-  (:alien-name "GdkEvent"))
 
-(defclass timed-event (event)
-  ((time
-    :allocation :alien
-    :accessor event-time
-    :initarg :time
-    :type (unsigned 32)))
-  (:metaclass alien-class))
-  
-(defclass delete-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass destroy-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass expose-event (event)
+;; Could this just as well have been a vector?
+(defclass rectangle (boxed)
   ((x
     :allocation :alien
-    :accessor event-x
+    :accessor rectangle-x
     :initarg :x
     :type int)
    (y
     :allocation :alien
-    :accessor event-y
+    :accessor rectangle-y
     :initarg :y
     :type int)
    (width
     :allocation :alien
-    :accessor event-width
+    :accessor rectangle-width
     :initarg :width
     :type int)
    (height
     :allocation :alien
-    :accessor event-height
+    :accessor rectangle-height
     :initarg :height
-    :type int)
-   (count
-    :allocation :alien
-    :accessor event-count
-    :initarg :count
     :type int))
-  (:metaclass alien-class))
-
-(defclass motion-notify-event (timed-event)
-  ((x
-    :allocation :alien
-    :accessor event-x
-    :initarg :x
-    :type double-float)
-   (y
+  (:metaclass boxed-class))
+
+
+(define-types-by-introspection "Gdk"
+  ("GdkFunction" :type gc-function)
+  ("GdkWMDecoration" :type wm-decoration)
+  ("GdkWMFunction" :type wm-function)
+  ("GdkGC" :type gc)
+  ("GdkGCX11" :type gc-x11)
+  ("GdkGCValuesMask" :type gc-values-mask)
+  ("GdkDrawableImplX11" :ignore t)
+  ("GdkWindowImplX11" :ignore t)
+  ("GdkPixmapImplX11" :ignore t)
+  ("GdkGCX11" :ignore t)
+  ("GdkColor" :ignore t)
+  ("GdkEvent" :ignore t)
+  ("GdkRectngle" :ignore t)
+  ("GdkCursor" :ignore t)
+  ("GdkFont" :ignore t) ; deprecated
+  ("GdkEventMask" :ignore t) ; manually defined
+
+  ("GdkDisplay"
+   :slots
+   ((name
+     :allocation :virtual
+     :getter "gdk_display_get_name"
+     :reader display-name
+     :type (copy-of string))
+    (screens
+     :allocation :virtual
+     :getter display-screens)
+    (devices
+     :allocation :virtual
+     :getter "gdk_display_list_devices"
+     :reader display-devices
+     :type (copy-of (glist device)))))
+
+  ("GdkDrawable"
+   :slots
+   ((display
+     :allocation :virtual
+     :getter "gdk_drawable_get_display"
+     :reader drawable-display
+     :type display)
+    (screen
+     :allocation :virtual
+     :getter "gdk_drawable_get_screen"
+     :reader drawable-screen
+     :type screen)
+    (visual
+     :allocation :virtual
+     :getter "gdk_drawable_get_visual"
+     :reader drawable-visual
+     :type visual)
+    (colormap
+     :allocation :virtual
+     :getter "gdk_drawable_get_colormap"
+     :setter "gdk_drawable_set_colormap"
+     :unbound nil
+     :accessor drawable-colormap
+     :initarg :colormap
+     :type colormap)
+    (depth
+     :allocation :virtual
+     :getter "gdk_drawable_get_depth"
+     :reader drawable-depth
+     :type int)
+    (with 
+     :allocation :virtual
+     :getter drawable-width)
+    (height
+     :allocation :virtual
+     :getter drawable-height)))
+  
+  ("GdkWindow"
+   :slots
+   ((state
+     :allocation :virtual
+     :getter "gdk_window_get_state"
+     :reader window-state
+     :type window-state)
+    (parent
+     :allocation :virtual
+     :getter "gdk_window_get_parent"
+     :reader window-parent
+     :type window)
+    (toplevel
+     :allocation :virtual
+     :getter "gdk_window_get_toplevel"
+     :reader window-toplevel
+     :type window)
+    (children
+     :allocation :virtual
+     :getter "gdk_window_get_children"
+     :reader window-children
+     :type (glist window))
+    (events
+     :allocation :virtual
+     :getter "gdk_window_get_events"
+     :setter "gdk_window_set_events"
+     :accessor window-events
+     :type event-mask)
+    (group
+     :allocation :virtual
+     :getter "gdk_window_get_group"
+     :setter "gdk_window_set_group"
+     :unbound nil
+     :accessor window-group
+     :type window))))
+
+
+(deftype bitmap () 'pixmap)
+
+(defclass cursor (boxed)
+  ((type
     :allocation :alien
-    :accessor event-y
-    :initarg :y
-    :type double-float)
-   (state
+    :reader cursor-type
+    :type cursor-type)
+   (ref-count
     :allocation :alien
-    :offset #.(size-of 'pointer)
-    :accessor event-state
-    :initarg :state
     :type unsigned-int)
-   (is-hint
-    :allocation :alien
-    :accessor event-is-hint
-    :initarg :is-hint
-    :type (signed 16) ; should it be (boolean 16)?
-    )
-   (device
-    :allocation :alien
-    :offset 2
-    :accessor event-device
-    :initarg :device
-    :type device)
-   (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 alien-class))
+   (display
+    :allocation :virtual
+    :getter "gdk_cursor_get_display"
+    :reader cursor-display
+    :type display))
+  (:metaclass boxed-class))
 
-(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
+
+(defclass geometry (struct)
+  ((min-width 
     :allocation :alien
-    :offset #.(size-of 'pointer)
-    :accessor event-state
-    :initarg :state
-    :type modifier-type)
-   (button
+    :accessor geometry-min-width
+    :initarg :min-width
+    :type int)
+   (min-height 
     :allocation :alien
-    :accessor event-button
-    :initarg :button
-    :type unsigned-int)
-   (device
+    :accessor geometry-min-height
+    :initarg :min-height
+    :type int)
+   (max-width 
     :allocation :alien
-    :accessor event-device
-    :initarg :device
-    :type device)
-   (root-x
+    :accessor geometry-max-width
+    :initarg :max-width
+    :type int)
+   (max-height 
     :allocation :alien
-    :accessor event-root-x
-    :initarg :root-x
-    :type double-float)
-   (root-y
+    :accessor geometry-max-height
+    :initarg :max-height
+    :type int)
+   (base-width 
     :allocation :alien
-    :accessor event-root-y
-    :initarg :root-y
-    :type double-float))
-  (:metaclass alien-class))
-
-(defclass 2-button-press-event (button-press-event)
-  ()
-  (:metaclass alien-class))
-
-(defclass 3-button-press-event (button-press-event)
-  ()
-  (:metaclass alien-class))
-
-(defclass button-release-event (button-press-event)
-  ()
-  (:metaclass alien-class))
-
-(defclass key-press-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass key-release-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass enter-notify-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass leave-notify-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass focus-change-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass configure-event (event)
-  ((x
+    :accessor geometry-base-width
+    :initarg :base-width
+    :type int)
+   (base-height 
     :allocation :alien
-    :accessor event-x
-    :initarg :x
+    :accessor geometry-base-height
+    :initarg :base-height
     :type int)
-   (y
+   (width-inc
     :allocation :alien
-    :accessor event-y
-    :initarg :y
+    :accessor geometry-width-inc
+    :initarg :width-inc
     :type int)
-   (width
+   (height-inc
     :allocation :alien
-    :accessor event-width
-    :initarg :width
+    :accessor geometry-height-inc
+    :initarg :height-inc
     :type int)
-   (height
+   (min-aspect
     :allocation :alien
-    :accessor event-height
-    :initarg :height
-    :type int))
-  (:metaclass alien-class))
-
-(defclass map-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass unmap-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass property-notify-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass selection-clear-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass selection-request-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass selection-notify-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass drag-enter-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass drag-leave-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass drag-motion-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass drag-status-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass drag-start-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass drag-finished-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass client-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass visibility-notify-event (event)
-  ((state
+    :accessor geometry-min-aspect
+    :initarg :min-aspect
+    :type double-float)
+   (max-aspect
     :allocation :alien
-    :accessor event-state
-    :initarg :state
-    :type visibility-state))
-  (:metaclass alien-class))
-
-(defclass no-expose-event (event)
-  ()
-  (:metaclass alien-class))
-
-(defclass scroll-event (timed-event)
-  ()
-  (:metaclass alien-class))
-
+    :accessor geometry-max-aspect
+    :initarg :max-aspect
+    :type double-float)
+   (gravity
+    :allocation :alien
+    :accessor geometry-gravity
+    :initarg :gravity
+    :type gravity))
+  (:metaclass struct-class))