X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/6d27e76ca1a6a6be040f0faf806a2be0a8afeb61..4641cb32a6f1f6288ca4c63c974b19af24171313:/gtk/gtkobject.lisp

diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp
index 64920ce..6a5cad4 100644
--- a/gtk/gtkobject.lisp
+++ b/gtk/gtkobject.lisp
@@ -1,5 +1,5 @@
 ;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
+;; Copyright (C) 1999-2001 Espen S. Johnsen <espen@users.sourceforge.org>
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -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: gtkobject.lisp,v 1.9 2001/05/29 16:00:52 espen Exp $
+;; $Id: gtkobject.lisp,v 1.16 2004/10/31 12:05:52 espen Exp $
 
 
 (in-package "GTK")
@@ -30,72 +30,12 @@
 ;   (intern (substitute #\- #\_ (string-upcase name)) package))
 
 
-;;; Argument stuff - to be removed soon
-
-(deftype arg () 'pointer)
-
-(defconstant +arg-type-offset+ 0)
-(defconstant +arg-name-offset+ 4)
-(defconstant +arg-value-offset+ 8)
-(defconstant +arg-size+ 16)
-
-(defbinding arg-new () arg
-  (type type-number))
-
-(defbinding %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
-	 (intern-destroy-function (type-from-number (arg-type arg)))
-	 arg +arg-value-offset+))
-      (deallocate-memory arg)))))
-
-(defbinding %arg-reset () nil
-  (arg arg))
-
-(defun arg-name (arg)
-  (funcall (intern-reader-function 'string) arg +arg-name-offset+))
-
-(defun (setf arg-name) (name arg)
-  (funcall (intern-writer-function '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 (intern-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 (intern-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 (intern-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)
-  (init-types-in-library "/opt/gnome/lib/libgtk-x11-1.3.so")
+  (init-types-in-library "libgtk-x11-2.0.so"
+   :ignore ("gtk_window_get_type_hint"))
 
   (defclass %object (gobject)
     ()
@@ -103,23 +43,22 @@
     (:alien-name "GtkObject")))
 
 
-(defmethod shared-initialize ((object %object) names &rest initargs
-			      &key signals)
-  (declare (ignore initargs names))
+(defmethod shared-initialize ((object %object) names &rest initargs &key signal)
+  (declare (ignore names signal))
   (call-next-method)
+  (object-ref object) ; inc ref count before sinking
   (%object-sink object)
-  (dolist (signal signals)
-    (apply #'signal-connect object signal)))
+  (dolist (signal-definition (get-all initargs :signal))
+    (apply #'signal-connect object signal-definition)))
 
-(defmethod initialize-proxy ((object %object) &rest initargs &key location)
+(defmethod initialize-proxy ((object %object) &rest initargs)
   (declare (ignore initargs))
   (call-next-method)
-  (%object-sink location))
+  (%object-sink object))
 
 (defbinding %object-sink () nil
   (object %object))
 
-
 ;;;; Main loop, timeouts and idle functions
 
 (declaim (inline events-pending-p main-iteration))
@@ -146,10 +85,26 @@
     (main-iteration-do 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)
+;;;; Initalization
+
+(defbinding (gtk-init "gtk_parse_args") () nil
+  "Initializes the library without opening the display."
+  (nil null)
+  (nil null))
+
+
+(defun clg-init (&optional display)
+  "Initializes the system and starts the event handling"
+  (unless (gdk:display-get-default)
+    (gdk:gdk-init)
+    (gtk-init)
+    (prog1
+	(gdk:display-open display)
+      (system:add-fd-handler 
+       (gdk:display-connection-number) :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))))
 
 
 
@@ -158,76 +113,96 @@
 (defvar *container-to-child-class-mappings* (make-hash-table))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass child-class (virtual-slot-class))
+  (defclass child-class (virtual-slot-class)
+    ())
 
   (defclass direct-child-slot-definition (direct-virtual-slot-definition)
-    ((arg-name :reader slot-definition-arg-name)))
+    ((pname :reader slot-definition-pname :initarg :pname)))
 
-  (defclass effective-child-slot-definition
-    (effective-virtual-slot-definition)))
+  (defclass effective-child-slot-definition (effective-virtual-slot-definition)
+    ((pname :reader slot-definition-pname :initarg :pname)))
 
 
-(defmethod shared-initialize ((class child-class) names &rest initargs
-			      &key container)
-  (declare (ignore initargs))
+(defmethod shared-initialize ((class child-class) names &key container)
   (call-next-method)
   (setf
    (gethash (find-class (first container)) *container-to-child-class-mappings*)
     class))
 
-(defmethod initialize-instance  ((slotd direct-child-slot-definition)
-				 &rest initargs &key arg-name)
-  (declare (ignore initargs))
-  (call-next-method)
-  (if arg-name
-      (setf (slot-value slotd 'arg-name) arg-name)
-    (error "Need argument name for slot with allocation :arg")))
+;; (defmethod initialize-instance  ((slotd direct-child-slot-definition)
+;; 				 &rest initargs &key pname)
+;;   (declare (ignore initargs))
+;;   (call-next-method)
+;;   (if pname
+;;       (setf (slot-value slotd 'pname) pname)
+;;     ; ???
+;;     (error "Need pname for slot with allocation :property")))
 
-(defmethod direct-slot-definition-class ((class child-class) initargs)
+(defmethod direct-slot-definition-class ((class child-class) &rest initargs)
   (case (getf initargs :allocation)
-    (:arg (find-class 'direct-child-slot-definition))
+    (:property (find-class 'direct-child-slot-definition))
     (t (call-next-method))))
 
-(defmethod effective-slot-definition-class ((class child-class) initargs)
+(defmethod effective-slot-definition-class ((class child-class) &rest initargs)
   (case (getf initargs :allocation)
-    (:arg (find-class 'effective-child-slot-definition))
+    (:property (find-class 'effective-child-slot-definition))
     (t (call-next-method))))
 
-(defmethod compute-virtual-slot-accessor
-    ((class child-class) (slotd effective-child-slot-definition) direct-slotds)
-  (with-slots (type) slotd
-    (let ((arg-name (slot-definition-arg-name (first direct-slotds)))
-	  (type-number (find-type-number type))
-; 	  (reader (intern-reader-function type))
-; 	  (writer (intern-writer-function type))
-; 	  (destroy (intern-destroy-function type))
-	  )
-      (list
+(defmethod compute-effective-slot-definition-initargs ((class child-class) direct-slotds)
+  (if (eq (most-specific-slot-value direct-slotds 'allocation) :property)
+      (nconc 
+       (list :pname (most-specific-slot-value direct-slotds 'pname))
+       (call-next-method))
+    (call-next-method)))
+
+(progn
+  (declaim (optimize (ext:inhibit-warnings 3)))
+  (defun %container-child-get-property (parent child pname gvalue))
+  (defun %container-child-set-property (parent child pname gvalue)))
+
+
+(defmethod initialize-internal-slot-functions ((slotd effective-child-slot-definition))
+  (let* ((type (slot-definition-type slotd))
+	 (pname (slot-definition-pname slotd))
+	 (type-number (find-type-number type)))
+    (unless (slot-boundp slotd 'reader-function)
+      (setf 
+       (slot-value slotd 'reader-function)
        #'(lambda (object)
 	   (with-slots (parent child) object	   
 	     (with-gc-disabled
-	       (let ((arg (arg-new type-number)))
-		 (setf (arg-name arg) arg-name)
-		 (%container-child-getv parent child arg)
-		 (prog1
-		     (funcall
-		      (intern-reader-function type)
-		      arg +arg-value-offset+)
-		   (arg-free arg t t))))))
+		 (let ((gvalue (gvalue-new type-number)))
+		   (%container-child-get-property parent child pname gvalue)
+		   (unwind-protect
+			(funcall
+			 (intern-reader-function type)
+			 gvalue +gvalue-value-offset+)
+		     (gvalue-free gvalue t))))))))
+    
+    (unless (slot-boundp slotd 'writer-function)
+      (setf 
+       (slot-value slotd 'writer-function)
        #'(lambda (value object)
 	   (with-slots (parent child) object	   
 	     (with-gc-disabled
-  	       (let ((arg (arg-new type-number)))
-		 (setf (arg-name arg) arg-name)
-		 (funcall
-		  (intern-writer-function type)
-		  value arg +arg-value-offset+)
-		 (%container-child-setv parent child arg)
-		 (funcall
-		  (intern-destroy-function type)
-		  arg +arg-value-offset+)
-		 (arg-free arg nil)
-		 value))))))))
+		 (let ((gvalue (gvalue-new type-number)))
+		   (funcall
+		    (intern-writer-function type)
+		    value gvalue +gvalue-value-offset+)
+		   (%container-child-set-property parent child pname gvalue)
+		   (funcall
+		    (intern-destroy-function type)
+		    gvalue +gvalue-value-offset+)
+		   (gvalue-free gvalue nil)
+		   value))))))
+    
+    (unless (slot-boundp slotd 'boundp-function)
+      (setf 
+       (slot-value slotd 'boundp-function)
+       #'(lambda (object)
+	   (declare (ignore object))
+	   t))))
+  (call-next-method)))
 
 
 (defmethod pcl::add-reader-method ((class child-class) generic-function slot-name)
@@ -256,7 +231,8 @@
 
 
 (defmethod validate-superclass ((class child-class) (super pcl::standard-class))
-  (subtypep (class-name super) 'container-child))
+  ;(subtypep (class-name super) 'container-child)
+  t)
 
 
 (defclass container-child ()
@@ -266,53 +242,32 @@
 
 ;;;;
 
-(defbinding %container-query-child-args () arg
-  (type-number type-number)
-  (nil null)
-  (n-args unsigned-int :out))
+(defbinding %container-class-list-child-properties () pointer
+  (class pointer)
+  (n-properties unsigned-int :out))
 
-(defun query-container-type-dependencies (type-number)
-  (let ((child-slot-types ()))
-    (multiple-value-bind (args n-args)
-	(%container-query-child-args type-number)
-      (dotimes (i n-args)
-	(push (arg-type (arg-array-ref args i)) child-slot-types)))
-    (delete-duplicates
-     (append (query-object-type-dependencies type-number) child-slot-types))))
+(defun query-container-class-child-properties (type-number)
+  (let ((class (type-class-ref type-number)))
+    (multiple-value-bind (array length)
+	(%container-class-list-child-properties class)
+      (unwind-protect
+	  (map-c-array 'list #'identity array 'param length)
+	(deallocate-memory array)))))
 
 (defun default-container-child-name (container-class)
   (intern (format nil "~A-CHILD" container-class)))
 
-(defun expand-container-type (type-number &optional slots)
-  (let* ((class (type-from-number type-number))
-	 (super (supertype type-number))
-	 (child-class (default-container-child-name class))
-	 (child-slots ()))
-    (multiple-value-bind (args n-args)
-	(%container-query-child-args type-number)
-      (dotimes (i n-args)
-	(let* ((arg (arg-array-ref args i))
-	       (arg-name (arg-name arg))
-	       (slot-name (default-slot-name
-			    (subseq arg-name (+ (position #\: arg-name) 2))))
-	       (type (type-from-number (arg-type arg) #|t|#)))
-	  (push
-	   `(,slot-name
-	     :allocation :arg
-	     :arg-name ,arg-name
-	     :accessor ,(default-slot-accessor child-class slot-name type)
-	     :initarg ,(intern (string slot-name) "KEYWORD")
-	     :type ,type)
-	   child-slots)))
-      `(progn
-	 ,(expand-gobject-type type-number slots)
-	 (defclass ,child-class
-	   (,(default-container-child-name super))
-	   ,child-slots
-	   (:metaclass child-class)
-	   (:container ,class))))))
-
-(register-derivable-type
- 'container "GtkContainer"
- :query 'query-container-type-dependencies
- :expand 'expand-container-type)
+(defun expand-container-type (type &optional options)
+  (let* ((class (type-from-number type))
+	 (super (supertype type))
+	 (child-class (default-container-child-name class)))
+    `(progn
+       ,(expand-gobject-type type options)
+       (defclass ,child-class (,(default-container-child-name super))
+	 ,(slot-definitions child-class 
+	   (query-container-class-child-properties type) nil)
+	 (:metaclass child-class)
+	 (:container ,class)))))
+
+
+(register-derivable-type 'container "GtkContainer" 'expand-container-type)