X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/0d07716fe78436ae6c9c324cabdd401c25e336af..d1f10587e8a57bbb0717057e734f8cf6765ebb36:/gdk/gdk.lisp diff --git a/gdk/gdk.lisp b/gdk/gdk.lisp index 54afe17..255018e 100644 --- a/gdk/gdk.lisp +++ b/gdk/gdk.lisp @@ -15,7 +15,7 @@ ;; 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: gdk.lisp,v 1.1 2000/08/14 16:44:39 espen Exp $ +;; $Id: gdk.lisp,v 1.5 2000/10/05 17:19:26 espen Exp $ (in-package "GDK") @@ -31,8 +31,39 @@ (defun find-event-class (event-type) (find-class (ecase event-type + (:delete 'delete-event) + (:destroy 'destroy-event) (:expose 'expose-event) - (:delete 'delete-event)))) + (:motion-notify 'motion-notify-event) + (:button-press 'button-press-event) + (:2button-press '2-button-press-event) + (:3button-press '3-button-press-event) + (:button-release 'button-release-event) + (:key-press 'key-press-event) + (:key-release 'key-release-event) + (:enter-notify 'enter-notify-event) + (:leave-notify 'leave-notify-event) + (:focus-change 'focus-change-event) + (:configure 'configure-event) + (:map 'map-event) + (:unmap 'unmap-event) + (:property-notify 'property-notify-event) + (:selection-clear 'selection-clear-event) + (:selection-request 'selection-request-event) + (:selection-notify 'selection-notify-event) + (:proximity-in 'proximity-in-event) + (:proximity-out 'proximity-out-event) + (:drag-enter 'drag-enter-event) + (:drag-leave 'drag-leave-event) + (:drag-motion 'drag-motion-event) + (:drag-status 'drag-status-event) + (:drop-start 'drop-start-event) + (:drop-finished 'drop-finished-event) + (:client-event 'client-event-event) + (:visibility-notify 'visibility-notify-event) + (:no-expose 'no-expose-event) + (:scroll 'scroll-event)))) + (deftype-method alien-copier event (type-spec) (declare (ignore type-spec)) @@ -43,17 +74,17 @@ '%event-free) (deftype-method translate-from-alien - event (type-spec location &optional (alloc :dynamic)) + event (type-spec location &optional (alloc :reference)) `(let ((location ,location)) (unless (null-pointer-p location) (let ((event-class (find-event-class (funcall (get-reader-function 'event-type) location 0)))) ,(ecase alloc - (:dynamic '(ensure-alien-instance event-class location)) + (:copy '(ensure-alien-instance event-class location)) (:static '(ensure-alien-instance event-class location :static t)) - (:copy '(ensure-alien-instance - event-class (%event-copy location)))))))) + (:reference '(ensure-alien-instance + event-class (%event-copy location)))))))) (define-foreign event-poll-fd () int) @@ -176,7 +207,7 @@ ;(define-foreign query-visual-types ..) -(define-foreign list-visuals () (double-list visual)) +(define-foreign list-visuals () (glist visual)) ;;; Windows @@ -367,13 +398,28 @@ ;;; Pixmaps +;; See the class definition for an explanation of this +(deftype-method alien-ref bitmap (type-spec) + (declare (ignore type-spec)) + '%drawable-ref) + +(deftype-method alien-unref bitmap (type-spec) + (declare (ignore type-spec)) + '%drawable-unref) + +(define-foreign %drawable-ref () pointer + (object (or bitmap pointer))) + +(define-foreign %drawable-unref () nil + (object (or bitmap pointer))) + + (define-foreign pixmap-new (width height depth &key window) pixmap (width int) (height int) (depth int) (window (or null window))) - (define-foreign %pixmap-colormap-create-from-xpm () pixmap (window (or null window)) (colormap (or null colormap)) @@ -381,31 +427,28 @@ (color (or null color)) (filename string)) -(define-foreign pixmap-colormap-create-from-xpm-d () pixmap +(define-foreign %pixmap-colormap-create-from-xpm-d () pixmap (window (or null window)) (colormap (or null colormap)) (mask bitmap :out) (color (or null color)) - (data pointer)) - -; (defun pixmap-create (source &key color window colormap) -; (let ((window -; (if (not (or window colormap)) -; (get-root-window) -; window))) -; (multiple-value-bind (pixmap bitmap) -; (typecase source -; ((or string pathname) -; (pixmap-colormap-create-from-xpm -; window colormap color (namestring (truename source)))) -; (t -; (with-array (data :initial-contents source :free-contents t) -; (pixmap-colormap-create-from-xpm-d window colormap color data)))) -; (if color -; (progn -; (bitmap-unref bitmap) -; pixmap) -; (values pixmap bitmap))))) + (data (vector string))) + +(defun pixmap-create (source &key color window colormap) + (let ((window + (if (not (or window colormap)) + (get-root-window) + window))) + (multiple-value-bind (pixmap mask) + (etypecase source + ((or string pathname) + (%pixmap-colormap-create-from-xpm + window colormap color (namestring (truename source)))) + ((vector string) + (%pixmap-colormap-create-from-xpm-d window colormap color source))) + (unreference-instance pixmap) + (unreference-instance mask) + (values pixmap mask)))) @@ -417,21 +460,24 @@ (float (truncate (* value 65535))))) (defmethod initialize-instance ((color color) &rest initargs - &key (colors #(0 0 0)) red green blue) + &key red green blue) (declare (ignore initargs)) (call-next-method) (with-slots ((%red red) (%green green) (%blue blue)) color (setf - %red (%scale-value (or red (svref colors 0))) - %green (%scale-value (or green (svref colors 1))) - %blue (%scale-value (or blue (svref colors 2)))))) + %red (%scale-value red) + %green (%scale-value green) + %blue (%scale-value blue)))) (defun ensure-color (color) (etypecase color (null nil) (color color) - (vector (make-instance 'color :colors color)))) + (vector + (make-instance + 'color :red (svref color 0) :green (svref color 1) + :blue (svref color 2)))))