X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/a250ff35c40f00d2f012c060b993f46438991210..da7fbbfdf2d30b28496ca2b4def6026f4aab964a:/gtk/gtkobject.lisp diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp index 3a2561e..223dade 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.2 2000-08-15 18:20:07 espen Exp $ +;; $Id: gtkobject.lisp,v 1.7 2000-11-09 20:30:16 espen Exp $ (in-package "GTK") + +;;;; Initializing + +(setf (alien-type-name 'pointer) "gpointer") + + ;;;; Misc utils (defun name-to-string (name) @@ -155,107 +161,25 @@ (let ((arg (arg-new 0))) (setf (arg-name arg) name) (object-get-arg object arg) - (let ((type (type-from-number (arg-type 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)) @@ -275,61 +199,34 @@ (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)) - -(defun signal-emit-stop (object signal) - (if (numberp signal) - (%signal-emit-stop object signal) - (%signal-emit-stop-by-name object signal))) +(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 %signal-connect-full - (object signal function after) unsigned-int - (object object) - ((name-to-string signal) string) +(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) - (nil boolean) - (after boolean)) - -(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 signal-disconnect () nil - (object object) - (handler unsigned-int)) + (*destroy-marshal* pointer)) -(define-foreign signal-handler-block () nil - (object object) - (handler unsigned-int)) +(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) -(define-foreign signal-handler-unblock () nil - (object object) - (handler unsigned-int)) ;;;; Metaclass used for subclasses of object