X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/5881f841aa27a317708e2f907fcee644dcbb5455..968da4bc0e768ead59f2bbd07981bad9b8609cc7:/gtk/gtkobject.lisp diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp index b9146ad..e4cdb52 100644 --- a/gtk/gtkobject.lisp +++ b/gtk/gtkobject.lisp @@ -1,5 +1,5 @@ ;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 1999-2000 Espen S. Johnsen +;; Copyright (C) 1999-2000 Espen S. Johnsen ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -15,11 +15,17 @@ ;; 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: gtkobject.lisp,v 1.3 2000-08-16 17:30:36 espen Exp $ +;; $Id: gtkobject.lisp,v 1.8 2001-01-28 14:23:38 espen Exp $ (in-package "GTK") + +;;;; Initializing + +(setf (alien-type-name 'pointer) "gpointer") + + ;;;; Misc utils (defun name-to-string (name) @@ -29,7 +35,7 @@ (intern (substitute #\- #\_ (string-upcase name)) package)) -;;;; Argument stuff +;;; Argument stuff - to be removed soon (deftype arg () 'pointer) @@ -113,7 +119,7 @@ (defmethod initialize-instance :after ((object object) &rest initargs &key) (declare (ignore initargs)) - (object-default-construct object) +; (object-default-construct object) (reference-instance object) (object-sink object)) @@ -124,140 +130,18 @@ (object-sink object)) -(define-foreign object-default-construct () nil - (object object)) - (define-foreign object-sink () nil (object object)) -(define-foreign ("gtk_object_getv" object-get-arg) () nil - (object object) - (1 unsigned-int) - (arg arg)) - -(define-foreign ("gtk_object_setv" object-set-arg) () nil - (object object) - (1 unsigned-int) - (arg arg)) - -(defun object-arg (object name) - (with-gc-disabled - (let ((arg (arg-new 0))) - (setf (arg-name arg) name) - (object-get-arg object arg) - (let ((type (type-from-number (arg-type arg)))) - (prog1 - (arg-value arg type) - (arg-free arg t)))))) - -(defun (setf object-arg) (value object name) - (with-gc-disabled - (let ((arg (arg-new 0))) - (setf (arg-name arg) name) - (object-get-arg object arg) - (let* ((type-number (arg-type arg)) - (type (type-from-number type-number))) - (%arg-reset arg) - (setf (arg-type arg) type-number) - (setf (arg-value arg type) value) - (object-set-arg object arg) - (arg-free arg t)))) - value) - - -;;;; Callback and user data mechanism - -(declaim (fixnum *user-data-count*)) - -(defvar *user-data* (make-hash-table)) -(defvar *user-data-count* 0) - -(defun register-user-data (object &optional destroy-function) - (check-type destroy-function (or null symbol function)) -; (incf *user-data-count*) - (setq *user-data-count* (the fixnum (1+ *user-data-count*))) - (setf - (gethash *user-data-count* *user-data*) - (cons object destroy-function)) - *user-data-count*) - - -(defun find-user-data (id) - (check-type id fixnum) - (multiple-value-bind (user-data p) (gethash id *user-data*) - (values (car user-data) p))) - - -(defun register-callback-function (function) - (check-type function (or null symbol function)) - ; We treat callbacks just as ordinary user data - (register-user-data function)) - -(defun callback-trampoline (callback-id nargs arg-array) - (declare (fixnum callback-id nargs)) - (let* ((return-arg (unless (null-pointer-p arg-array) - (arg-array-ref arg-array nargs))) - (return-type (if return-arg - (type-from-number (arg-type return-arg)) - nil)) - (args nil) - (callback-function (find-user-data callback-id))) - - (dotimes (n nargs) - (push (arg-value (arg-array-ref arg-array (- nargs n 1))) args)) - - (labels ((invoke-callback () - (restart-case - (unwind-protect - (let ((return-value (apply callback-function args))) - (when return-type - (setf (return-arg-value return-arg) return-value)))) - - (continue nil :report "Return from callback function" - (when return-type - (format - *query-io* - "Enter return value of type ~S: " - return-type) - (force-output *query-io*) - (setf - (return-arg-value return-arg) - (eval (read *query-io*))))) - (re-invoke nil :report "Re-invoke callback function" - (invoke-callback))))) - (invoke-callback)))) - - -(defun destroy-user-data (id) - (check-type id fixnum) - (let ((user-data (gethash id *user-data*))) - (when (cdr user-data) - (funcall (cdr user-data) (car user-data)))) - (remhash id *user-data*)) - - -(defvar *callback-marshal* (system:foreign-symbol-address "callback_marshal")) -(defvar *destroy-marshal* (system:foreign-symbol-address "destroy_marshal")) - -(defun after-gc-hook () - (setf - (extern-alien "callback_trampoline" system-area-pointer) - (make-pointer (kernel:get-lisp-obj-address #'callback-trampoline)) - (extern-alien "destroy_user_data" system-area-pointer) - (make-pointer (kernel:get-lisp-obj-address #'destroy-user-data)))) - -(pushnew 'after-gc-hook ext:*after-gc-hooks*) -(after-gc-hook) - - - -;;;; Main loop +;;;; Main loop, timeouts and idle functions (declaim (inline events-pending-p main-iteration)) (define-foreign ("gtk_events_pending" events-pending-p) () boolean) +(define-foreign get-current-event () gdk:event) + (define-foreign main-do-event () nil (event gdk:event)) @@ -277,131 +161,46 @@ (main-iteration nil) (main-iterate-all))) -(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) - - - -;;;; Signals - -(define-foreign %signal-emit-stop () nil - (object object) - (signal-id unsigned-int)) - -(define-foreign %signal-emit-stop-by-name (object signal) nil - (object object) - ((name-to-string signal) string)) +; (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)) -(defun signal-emit-stop (object signal) - (if (numberp signal) - (%signal-emit-stop object signal) - (%signal-emit-stop-by-name object signal))) - -(define-foreign %signal-connect-full - (object signal function after) unsigned-int - (object object) - ((name-to-string signal) string) - (0 unsigned-long) - (*callback-marshal* pointer) - ((register-callback-function function) unsigned-long) - (*destroy-marshal* pointer) - (nil boolean) - (after boolean)) +; (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)) -(defun signal-connect (object signal function - &key after ((:object callback-object))) - (let* ((callback-object (if (eq callback-object t) - object - callback-object)) - (callback-function - (if callback-object - #'(lambda (&rest args) (apply function callback-object args)) - function))) - (%signal-connect-full object signal callback-function after))) +; (define-foreign idle-remove () nil +; (idle-handler-id unsigned-int)) -(define-foreign signal-disconnect () nil - (object object) - (handler unsigned-int)) -(define-foreign signal-handler-block () nil - (object object) - (handler 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) -(define-foreign signal-handler-unblock () nil - (object object) - (handler unsigned-int)) ;;;; Metaclass used for subclasses of object (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass object-class (gobject-class)) - - (defclass direct-object-slot-definition (direct-virtual-slot-definition)) - - (defclass effective-object-slot-definition - (effective-virtual-slot-definition))) - - -(defmethod initialize-instance :after ((slotd direct-object-slot-definition) - &rest initargs &key) - (declare (ignore initargs)) - (unless (slot-boundp slotd 'location) - (with-slots (pcl::name location pcl::class) slotd - (setf - location - (format nil "~A::~A" - (alien-type-name (class-name pcl::class)) - (name-to-string pcl::name)))))) - - -(defmethod direct-slot-definition-class ((class object-class) initargs) - (case (getf initargs :allocation) - (:arg (find-class 'direct-object-slot-definition)) - (t (call-next-method)))) - - -(defmethod effective-slot-definition-class ((class object-class) initargs) - (case (getf initargs :allocation) - (:arg (find-class 'effective-object-slot-definition)) - (t (call-next-method)))) - - -(defmethod compute-virtual-slot-location - ((class object-class) (slotd effective-object-slot-definition) - direct-slotds) - (with-slots (type) slotd - (let ((location (slot-definition-location (first direct-slotds))) - (type-number (find-type-number type)) - (reader (get-reader-function type)) - (writer (get-writer-function type)) - (destroy (get-destroy-function type))) - (list - #'(lambda (object) - (with-gc-disabled - (let ((arg (arg-new type-number))) - (setf (arg-name arg) location) - (object-get-arg object arg) - (prog1 - (funcall reader arg +arg-value-offset+) - (arg-free arg t t))))) - #'(lambda (value object) - (with-gc-disabled - (let ((arg (arg-new type-number))) - (setf (arg-name arg) location) - (funcall writer value arg +arg-value-offset+) - (object-set-arg object arg) - (funcall destroy arg +arg-value-offset+) - (arg-free arg nil) - value))))))) + (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