[clg] / gtk / gtkobject.lisp

;; Common Lisp bindings for GTK+ v2.0
;; Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.no>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy 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: gtkobject.lisp,v 1.6 2000-09-04 22:14:54 espen Exp $


(in-package "GTK")


;;;; Initializing

(setf (alien-type-name 'pointer) "gpointer")


;;;; Misc utils

(defun name-to-string (name)
  (substitute #\_ #\- (string-downcase (string name))))

(defun string-to-name (name &optional (package "KEYWORD"))
  (intern (substitute #\- #\_ (string-upcase name)) package))


;;;; Argument stuff

(deftype arg () 'pointer)

(defconstant +arg-type-offset+ 0)
(defconstant +arg-name-offset+ 4)
(defconstant +arg-value-offset+ 8)
(defconstant +arg-size+ 16)

(define-foreign arg-new () arg
  (type type-number))

(define-foreign %arg-free () nil
  (arg arg)
  (free-contents boolean))

(defun arg-free (arg free-contents &optional alien)
  (cond
   (alien (%arg-free arg free-contents))
   (t
    (unless (null-pointer-p arg)
      (when free-contents
	(funcall
	 (get-destroy-function (type-from-number (arg-type arg)))
	 arg +arg-value-offset+))
      (deallocate-memory arg)))))

(define-foreign %arg-reset () nil
  (arg arg))

(defun arg-name (arg)
  (funcall (get-reader-function '(static string)) arg +arg-name-offset+))

(defun (setf arg-name) (name arg)
  (funcall (get-writer-function '(static string)) name arg +arg-name-offset+)
  name)

(defun arg-type (arg)
  (system:sap-ref-32 arg +arg-type-offset+))

(defun (setf arg-type) (type arg)
  (setf (system:sap-ref-32 arg +arg-type-offset+) type))

(defun arg-value (arg &optional (type (type-from-number (arg-type arg))))
  (funcall (get-reader-function type) arg +arg-value-offset+))

;; One should never call this function on an arg whose value is already set
(defun (setf arg-value)
    (value arg &optional (type (type-from-number (arg-type arg))))
  (funcall (get-writer-function type) value arg +arg-value-offset+)
  value)

(defun (setf return-arg-value)
    (value arg &optional (type (type-from-number (arg-type arg))))
  ; this is probably causing a memory leak
  (funcall (get-writer-function type) value (arg-value arg 'pointer) 0)
  value)

(defun arg-array-ref (arg0 index)
  (system:sap+ arg0 (* index +arg-size+)))


;;;; Superclass for the gtk class hierarchy

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defclass object (gobject)
    ()
;   ((flags
;     :allocation :alien
;     :accessor object-flags
;     :type object-flags))
    (:metaclass gobject-class)
    (:alien-name "GtkObject")))


(defmethod shared-initialize ((object object) names &rest initargs &key signals)
  (declare (ignore initargs names))
  (call-next-method)
  (dolist (signal signals)
    (apply #'signal-connect object signal)))


(defmethod initialize-instance :after ((object object) &rest initargs &key)
  (declare (ignore initargs))
  (object-default-construct object)
  (reference-instance object)
  (object-sink object))


(defmethod from-alien-initialzie-instance ((object object) &rest initargs)
  (declare (ignore initargs))
  (call-next-method)
  (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 mechanism

(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))))

(defvar *callback-marshal* (system:foreign-symbol-address "callback_marshal"))
(setq *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, 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))

(define-foreign main () nil)

(define-foreign main-level () int)

(define-foreign main-quit () nil)

(define-foreign
    ("gtk_main_iteration_do" main-iteration) (&optional (blocking t)) boolean
  (blocking boolean))

(defun main-iterate-all (&rest args)
  (declare (ignore args))
  (when (events-pending-p)
    (main-iteration nil)
    (main-iterate-all)))

(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 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))

(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)


;;;; 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 %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))

(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))

(define-foreign signal-handler-block () nil
  (object object)
  (handler unsigned-int))

(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)))))))


(defmethod validate-superclass ((class object-class)
				(super pcl::standard-class))
  (subtypep (class-name super) 'object))
  

;;;; Metaclasses used for widgets and containers

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defclass widget-class (object-class))

  (defclass container-class (widget-class)
    (child-class)))


(defvar *child-to-container-class-mappings* (make-hash-table))

(defmethod shared-initialize ((class container-class) names
			      &rest initargs &key name child-class)
  (declare (ignore initargs))
  (call-next-method)
  (with-slots ((child-class-slot child-class)) class
    (setf
     child-class-slot
     (or
      (first child-class)
      (intern (format nil "~A-CHILD" (or name (class-name class)))))
     (gethash child-class-slot *child-to-container-class-mappings*)
     class)))


(defmethod validate-superclass ((class widget-class)
				(super pcl::standard-class))
  (subtypep (class-name super) 'widget))

(defmethod validate-superclass ((class container-class)
				(super pcl::standard-class))
  (subtypep (class-name super) 'container))


;;;; Metaclass for child classes

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defclass child-class (virtual-class))

  (defclass direct-child-slot-definition (direct-virtual-slot-definition))

  (defclass effective-child-slot-definition
    (effective-virtual-slot-definition)))


(defmethod initialize-instance  ((slotd direct-child-slot-definition)
				 &rest initargs &key)
  (declare (ignore initargs))
  (call-next-method)
  (unless (slot-boundp slotd 'location)
    (with-slots (pcl::name location pcl::class) slotd
      (setf
       location 
       (format nil "~A::~A"
        (alien-type-name
	 (gethash (class-name pcl::class) *child-to-container-class-mappings*))
	(name-to-string pcl::name))))))


(defmethod direct-slot-definition-class ((class child-class) initargs)
  (case (getf initargs :allocation)
    (:arg (find-class 'direct-child-slot-definition))
    (t (call-next-method))))


(defmethod effective-slot-definition-class ((class child-class) initargs)
  (case (getf initargs :allocation)
    (:arg (find-class 'effective-child-slot-definition))
    (t (call-next-method))))
  

(defmethod compute-virtual-slot-location
    ((class child-class) (slotd effective-child-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-slots (parent child) object	   
	     (with-gc-disabled
	       (let ((arg (arg-new type-number)))
		 (setf (arg-name arg) location)
		 (container-child-get-arg parent child arg)
		 (prog1
		     (funcall reader arg +arg-value-offset+)
		   (arg-free arg t t))))))
       #'(lambda (value object)
	   (with-slots (parent child) object	   
	     (with-gc-disabled
  	       (let ((arg (arg-new type-number)))
		 (setf (arg-name arg) location)
		 (funcall writer value arg +arg-value-offset+)
		 (container-child-set-arg parent child arg)
		 (funcall destroy arg +arg-value-offset+)
		 (arg-free arg nil)
		 value))))))))


(defmethod pcl::add-reader-method ((class child-class) generic-function slot-name)
  (add-method
   generic-function
   (make-instance 'standard-method
		  :specializers (list (find-class 'widget))
		  :lambda-list '(widget)
		  :function #'(lambda (args next-methods)
				(declare (ignore next-methods))
				(child-slot-value (first args) slot-name)))))

(defmethod pcl::add-writer-method
    ((class child-class) generic-function slot-name)
  (add-method
   generic-function
   (make-instance 'standard-method
		  :specializers (list (find-class t) (find-class 'widget))
		  :lambda-list '(value widget)
		  :function #'(lambda (args next-methods)
				(declare (ignore next-methods))
				(destructuring-bind (value widget) args
				  (setf
				   (child-slot-value widget slot-name)
				   value))))))


(defmethod validate-superclass ((class child-class) (super pcl::standard-class))
  (subtypep (class-name super) 'container-child))
Commit	Line	Data
560af5c5	1	;; Common Lisp bindings for GTK+ v2.0
	2	;; Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.no>
	3	;;
	4	;; This library is free software; you can redistribute it and/or
	5	;; modify it under the terms of the GNU Lesser General Public
	6	;; License as published by the Free Software Foundation; either
	7	;; version 2 of the License, or (at your option) any later version.
	8	;;
	9	;; This library is distributed in the hope that it will be useful,
	10	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	11	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	12	;; Lesser General Public License for more details.
	13	;;
	14	;; You should have received a copy of the GNU Lesser General Public
	15	;; License along with this library; if not, write to the Free Software
	16	;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	17
8bf63d9f	18	;; $Id: gtkobject.lisp,v 1.6 2000-09-04 22:14:54 espen Exp $
560af5c5	19
	20
	21	(in-package "GTK")
	22
8bf63d9f	23
	24	;;;; Initializing
	25
	26	(setf (alien-type-name 'pointer) "gpointer")
	27
	28
560af5c5	29	;;;; Misc utils
	30
	31	(defun name-to-string (name)
	32	(substitute #\_ #\- (string-downcase (string name))))
	33
	34	(defun string-to-name (name &optional (package "KEYWORD"))
	35	(intern (substitute #\- #\_ (string-upcase name)) package))
	36
	37
	38	;;;; Argument stuff
	39
	40	(deftype arg () 'pointer)
	41
	42	(defconstant +arg-type-offset+ 0)
	43	(defconstant +arg-name-offset+ 4)
	44	(defconstant +arg-value-offset+ 8)
	45	(defconstant +arg-size+ 16)
	46
	47	(define-foreign arg-new () arg
	48	(type type-number))
	49
	50	(define-foreign %arg-free () nil
	51	(arg arg)
	52	(free-contents boolean))
	53
	54	(defun arg-free (arg free-contents &optional alien)
	55	(cond
	56	(alien (%arg-free arg free-contents))
	57	(t
	58	(unless (null-pointer-p arg)
	59	(when free-contents
	60	(funcall
	61	(get-destroy-function (type-from-number (arg-type arg)))
	62	arg +arg-value-offset+))
	63	(deallocate-memory arg)))))
	64
	65	(define-foreign %arg-reset () nil
	66	(arg arg))
	67
	68	(defun arg-name (arg)
	69	(funcall (get-reader-function '(static string)) arg +arg-name-offset+))
	70
	71	(defun (setf arg-name) (name arg)
	72	(funcall (get-writer-function '(static string)) name arg +arg-name-offset+)
	73	name)
	74
	75	(defun arg-type (arg)
	76	(system:sap-ref-32 arg +arg-type-offset+))
	77
	78	(defun (setf arg-type) (type arg)
	79	(setf (system:sap-ref-32 arg +arg-type-offset+) type))
	80
	81	(defun arg-value (arg &optional (type (type-from-number (arg-type arg))))
	82	(funcall (get-reader-function type) arg +arg-value-offset+))
	83
	84	;; One should never call this function on an arg whose value is already set
	85	(defun (setf arg-value)
	86	(value arg &optional (type (type-from-number (arg-type arg))))
a250ff35	87	(funcall (get-writer-function type) value arg +arg-value-offset+)
560af5c5	88	value)
	89
	90	(defun (setf return-arg-value)
	91	(value arg &optional (type (type-from-number (arg-type arg))))
	92	; this is probably causing a memory leak
	93	(funcall (get-writer-function type) value (arg-value arg 'pointer) 0)
	94	value)
	95
	96	(defun arg-array-ref (arg0 index)
	97	(system:sap+ arg0 (* index +arg-size+)))
	98
	99
	100	;;;; Superclass for the gtk class hierarchy
	101
	102	(eval-when (:compile-toplevel :load-toplevel :execute)
	103	(defclass object (gobject)
	104	()
	105	; ((flags
	106	; :allocation :alien
	107	; :accessor object-flags
	108	; :type object-flags))
	109	(:metaclass gobject-class)
	110	(:alien-name "GtkObject")))
	111
	112
	113	(defmethod shared-initialize ((object object) names &rest initargs &key signals)
	114	(declare (ignore initargs names))
	115	(call-next-method)
	116	(dolist (signal signals)
	117	(apply #'signal-connect object signal)))
	118
	119
	120	(defmethod initialize-instance :after ((object object) &rest initargs &key)
	121	(declare (ignore initargs))
	122	(object-default-construct object)
	123	(reference-instance object)
	124	(object-sink object))
	125
	126
	127	(defmethod from-alien-initialzie-instance ((object object) &rest initargs)
	128	(declare (ignore initargs))
	129	(call-next-method)
	130	(object-sink object))
	131
	132
	133	(define-foreign object-default-construct () nil
	134	(object object))
	135
	136	(define-foreign object-sink () nil
	137	(object object))
	138
	139	(define-foreign ("gtk_object_getv" object-get-arg) () nil
	140	(object object)
	141	(1 unsigned-int)
	142	(arg arg))
	143
	144	(define-foreign ("gtk_object_setv" object-set-arg) () nil
	145	(object object)
	146	(1 unsigned-int)
	147	(arg arg))
	148
	149	(defun object-arg (object name)
	150	(with-gc-disabled
	151	(let ((arg (arg-new 0)))
152	(setf (arg-name arg) name)
153	(object-get-arg object arg)
154	(let ((type (type-from-number (arg-type arg))))
155	(prog1
156	(arg-value arg type)
157	(arg-free arg t))))))
158
159	(defun (setf object-arg) (value object name)
160	(with-gc-disabled
161	(let ((arg (arg-new 0)))
162	(setf (arg-name arg) name)
163	(object-get-arg object arg)
5881f841	164	(let* ((type-number (arg-type arg))
5881f841	165	(type (type-from-number type-number)))
560af5c5	166	(%arg-reset arg)
5881f841	167	(setf (arg-type arg) type-number)
560af5c5	168	(setf (arg-value arg type) value)
	169	(object-set-arg object arg)
	170	(arg-free arg t))))
	171	value)
	172
	173
86d9d6ab	174	;;;; Callback mechanism
560af5c5	175
	176	(defun register-callback-function (function)
	177	(check-type function (or null symbol function))
	178	; We treat callbacks just as ordinary user data
	179	(register-user-data function))
	180
560af5c5	181	(defun callback-trampoline (callback-id nargs arg-array)
	182	(declare (fixnum callback-id nargs))
	183	(let* ((return-arg (unless (null-pointer-p arg-array)
	184	(arg-array-ref arg-array nargs)))
	185	(return-type (if return-arg
	186	(type-from-number (arg-type return-arg))
	187	nil))
	188	(args nil)
	189	(callback-function (find-user-data callback-id)))
	190
	191	(dotimes (n nargs)
	192	(push (arg-value (arg-array-ref arg-array (- nargs n 1))) args))
	193
	194	(labels ((invoke-callback ()
	195	(restart-case
	196	(unwind-protect
	197	(let ((return-value (apply callback-function args)))
	198	(when return-type
	199	(setf (return-arg-value return-arg) return-value))))
	200
	201	(continue nil :report "Return from callback function"
	202	(when return-type
	203	(format
	204	query-io
	205	"Enter return value of type ~S: "
	206	return-type)
	207	(force-output query-io)
	208	(setf
	209	(return-arg-value return-arg)
	210	(eval (read query-io)))))
	211	(re-invoke nil :report "Re-invoke callback function"
	212	(invoke-callback)))))
	213	(invoke-callback))))
	214
560af5c5	215	(defvar callback-marshal (system:foreign-symbol-address "callback_marshal"))
86d9d6ab	216	(setq destroy-marshal (system:foreign-symbol-address "destroy_marshal"))
560af5c5	217
	218	(defun after-gc-hook ()
	219	(setf
	220	(extern-alien "callback_trampoline" system-area-pointer)
	221	(make-pointer (kernel:get-lisp-obj-address #'callback-trampoline))
	222	(extern-alien "destroy_user_data" system-area-pointer)
	223	(make-pointer (kernel:get-lisp-obj-address #'destroy-user-data))))
	224
	225	(pushnew 'after-gc-hook ext:after-gc-hooks)
	226	(after-gc-hook)
	227
	228
	229
aace61f5	230	;;;; Main loop, timeouts and idle functions
560af5c5	231
	232	(declaim (inline events-pending-p main-iteration))
	233
	234	(define-foreign ("gtk_events_pending" events-pending-p) () boolean)
	235
aace61f5	236	(define-foreign get-current-event () gdk:event)
aace61f5	237
560af5c5	238	(define-foreign main-do-event () nil
	239	(event gdk:event))
	240
	241	(define-foreign main () nil)
	242
	243	(define-foreign main-level () int)
	244
	245	(define-foreign main-quit () nil)
	246
	247	(define-foreign
	248	("gtk_main_iteration_do" main-iteration) (&optional (blocking t)) boolean
	249	(blocking boolean))
	250
	251	(defun main-iterate-all (&rest args)
	252	(declare (ignore args))
	253	(when (events-pending-p)
	254	(main-iteration nil)
	255	(main-iterate-all)))
	256
aace61f5	257	(define-foreign ("gtk_timeout_add_full" timeout-add)
	258	(interval function) unsigned-int
	259	(interval (unsigned 32))
	260	(0 unsigned-long)
	261	(callback-marshal pointer)
	262	((register-callback-function function) unsigned-long)
	263	(destroy-marshal pointer))
	264
	265	(define-foreign timeout-remove () nil
	266	(timeout-handler-id unsigned-int))
	267
	268	(define-foreign ("gtk_idle_add_full" idle-add)
	269	(function &optional (priority 200)) unsigned-int
	270	(priority int)
	271	(0 unsigned-long)
	272	(callback-marshal pointer)
	273	((register-callback-function function) unsigned-long)
	274	(destroy-marshal pointer))
	275
	276	(define-foreign idle-remove () nil
	277	(idle-handler-id unsigned-int))
	278
	279
560af5c5	280	(system:add-fd-handler (gdk:event-poll-fd) :input #'main-iterate-all)
	281	(setq lisp::periodic-polling-function #'main-iterate-all)
	282	(setq lisp::max-event-to-sec 0)
	283	(setq lisp::max-event-to-usec 1000)
	284
	285
	286
	287	;;;; Signals
	288
	289	(define-foreign %signal-emit-stop () nil
	290	(object object)
	291	(signal-id unsigned-int))
	292
	293	(define-foreign %signal-emit-stop-by-name (object signal) nil
	294	(object object)
	295	((name-to-string signal) string))
	296
	297	(defun signal-emit-stop (object signal)
	298	(if (numberp signal)
	299	(%signal-emit-stop object signal)
	300	(%signal-emit-stop-by-name object signal)))
	301
	302	(define-foreign %signal-connect-full
	303	(object signal function after) unsigned-int
	304	(object object)
	305	((name-to-string signal) string)
	306	(0 unsigned-long)
	307	(callback-marshal pointer)
	308	((register-callback-function function) unsigned-long)
	309	(destroy-marshal pointer)
	310	(nil boolean)
	311	(after boolean))
	312
	313	(defun signal-connect (object signal function
	314	&key after ((:object callback-object)))
	315	(let* ((callback-object (if (eq callback-object t)
	316	object
	317	callback-object))
	318	(callback-function
	319	(if callback-object
	320	#'(lambda (&rest args) (apply function callback-object args))
	321	function)))
	322	(%signal-connect-full object signal callback-function after)))
	323
	324	(define-foreign signal-disconnect () nil
	325	(object object)
	326	(handler unsigned-int))
	327
	328	(define-foreign signal-handler-block () nil
	329	(object object)
	330	(handler unsigned-int))
	331
	332	(define-foreign signal-handler-unblock () nil
	333	(object object)
	334	(handler unsigned-int))
	335
	336
	337	;;;; Metaclass used for subclasses of object
	338
	339	(eval-when (:compile-toplevel :load-toplevel :execute)
	340	(defclass object-class (gobject-class))
	341
	342	(defclass direct-object-slot-definition (direct-virtual-slot-definition))
	343
344	(defclass effective-object-slot-definition
345	(effective-virtual-slot-definition)))
346
347
348	(defmethod initialize-instance :after ((slotd direct-object-slot-definition)
349	&rest initargs &key)
350	(declare (ignore initargs))
351	(unless (slot-boundp slotd 'location)
352	(with-slots (pcl::name location pcl::class) slotd
353	(setf
354	location
355	(format nil "~A::~A"
356	(alien-type-name (class-name pcl::class))
357	(name-to-string pcl::name))))))
358
359
360	(defmethod direct-slot-definition-class ((class object-class) initargs)
361	(case (getf initargs :allocation)
362	(:arg (find-class 'direct-object-slot-definition))
363	(t (call-next-method))))
364
365
366	(defmethod effective-slot-definition-class ((class object-class) initargs)
367	(case (getf initargs :allocation)
368	(:arg (find-class 'effective-object-slot-definition))
369	(t (call-next-method))))
370
371
372	(defmethod compute-virtual-slot-location
373	((class object-class) (slotd effective-object-slot-definition)
374	direct-slotds)
375	(with-slots (type) slotd
376	(let ((location (slot-definition-location (first direct-slotds)))
377	(type-number (find-type-number type))
378	(reader (get-reader-function type))
379	(writer (get-writer-function type))
380	(destroy (get-destroy-function type)))
381	(list
382	#'(lambda (object)
383	(with-gc-disabled
384	(let ((arg (arg-new type-number)))
385	(setf (arg-name arg) location)
386	(object-get-arg object arg)
387	(prog1
388	(funcall reader arg +arg-value-offset+)
389	(arg-free arg t t)))))
390	#'(lambda (value object)
391	(with-gc-disabled
392	(let ((arg (arg-new type-number)))
393	(setf (arg-name arg) location)
394	(funcall writer value arg +arg-value-offset+)
395	(object-set-arg object arg)
396	(funcall destroy arg +arg-value-offset+)
397	(arg-free arg nil)
398	value)))))))
399
400
401	(defmethod validate-superclass ((class object-class)
402	(super pcl::standard-class))
403	(subtypep (class-name super) 'object))
404
405
406	;;;; Metaclasses used for widgets and containers
407
408	(eval-when (:compile-toplevel :load-toplevel :execute)
409	(defclass widget-class (object-class))
410
411	(defclass container-class (widget-class)
412	(child-class)))
413
414
415	(defvar child-to-container-class-mappings (make-hash-table))
416
417	(defmethod shared-initialize ((class container-class) names
418	&rest initargs &key name child-class)
419	(declare (ignore initargs))
420	(call-next-method)
421	(with-slots ((child-class-slot child-class)) class
422	(setf
423	child-class-slot
424	(or
425	(first child-class)
426	(intern (format nil "~A-CHILD" (or name (class-name class)))))
427	(gethash child-class-slot child-to-container-class-mappings)
428	class)))
429
430
431	(defmethod validate-superclass ((class widget-class)
432	(super pcl::standard-class))
433	(subtypep (class-name super) 'widget))
434
435	(defmethod validate-superclass ((class container-class)
436	(super pcl::standard-class))
437	(subtypep (class-name super) 'container))
438
439
440
441	;;;; Metaclass for child classes
442
443	(eval-when (:compile-toplevel :load-toplevel :execute)
444	(defclass child-class (virtual-class))
445
446	(defclass direct-child-slot-definition (direct-virtual-slot-definition))
447
448	(defclass effective-child-slot-definition
449	(effective-virtual-slot-definition)))
450
451
452	(defmethod initialize-instance ((slotd direct-child-slot-definition)
453	&rest initargs &key)
454	(declare (ignore initargs))
455	(call-next-method)
456	(unless (slot-boundp slotd 'location)
457	(with-slots (pcl::name location pcl::class) slotd
458	(setf
459	location
460	(format nil "~A::~A"
461	(alien-type-name
462	(gethash (class-name pcl::class) child-to-container-class-mappings))
463	(name-to-string pcl::name))))))
464
465
466	(defmethod direct-slot-definition-class ((class child-class) initargs)
467	(case (getf initargs :allocation)
468	(:arg (find-class 'direct-child-slot-definition))
469	(t (call-next-method))))
470
471
472	(defmethod effective-slot-definition-class ((class child-class) initargs)
473	(case (getf initargs :allocation)
474	(:arg (find-class 'effective-child-slot-definition))
475	(t (call-next-method))))
476
477
478	(defmethod compute-virtual-slot-location
479	((class child-class) (slotd effective-child-slot-definition) direct-slotds)
480	(with-slots (type) slotd
481	(let ((location (slot-definition-location (first direct-slotds)))
482	(type-number (find-type-number type))
483	(reader (get-reader-function type))
484	(writer (get-writer-function type))
485	(destroy (get-destroy-function type)))
486	(list
487	#'(lambda (object)
488	(with-slots (parent child) object
489	(with-gc-disabled
490	(let ((arg (arg-new type-number)))
491	(setf (arg-name arg) location)
492	(container-child-get-arg parent child arg)
493	(prog1
494	(funcall reader arg +arg-value-offset+)
495	(arg-free arg t t))))))
496	#'(lambda (value object)
497	(with-slots (parent child) object
498	(with-gc-disabled
499	(let ((arg (arg-new type-number)))
500	(setf (arg-name arg) location)
501	(funcall writer value arg +arg-value-offset+)
502	(container-child-set-arg parent child arg)
503	(funcall destroy arg +arg-value-offset+)
504	(arg-free arg nil)
505	value))))))))
506
507
508	(defmethod pcl::add-reader-method ((class child-class) generic-function slot-name)
509	(add-method
510	generic-function
511	(make-instance 'standard-method
512	:specializers (list (find-class 'widget))
513	:lambda-list '(widget)
514	:function #'(lambda (args next-methods)
515	(declare (ignore next-methods))
516	(child-slot-value (first args) slot-name)))))
517
518	(defmethod pcl::add-writer-method
519	((class child-class) generic-function slot-name)
520	(add-method
521	generic-function
522	(make-instance 'standard-method
523	:specializers (list (find-class t) (find-class 'widget))
524	:lambda-list '(value widget)
525	:function #'(lambda (args next-methods)
526	(declare (ignore next-methods))
527	(destructuring-bind (value widget) args
528	(setf
529	(child-slot-value widget slot-name)
530	value))))))
531
532
533	(defmethod validate-superclass ((class child-class) (super pcl::standard-class))
534	(subtypep (class-name super) 'container-child))
535
536