[lgtk-cvs] CVS update: lgtk/src/gtkbindings.lisp lgtk/src/gtkclasshierarchy.lisp lgtk/src/gtklisp.lisp lgtk/src/gtknexus.lisp lgtk/src/nexus.lisp lgtk/src/widgets.lisp

[Mario Mommer]

Update of /project/lgtk/cvsroot/lgtk/src
In directory common-lisp.net:/tmp/cvs-serv20598/src

Modified Files:
	gtkbindings.lisp gtkclasshierarchy.lisp gtklisp.lisp 
	gtknexus.lisp nexus.lisp widgets.lisp 
Log Message:
The identity of accessory objects (like GSlist) gets properly handled.

Date: Fri Oct 31 05:52:53 2003
Author: mmommer

Index: lgtk/src/gtkbindings.lisp
diff -u lgtk/src/gtkbindings.lisp:1.1.1.1 lgtk/src/gtkbindings.lisp:1.2
--- lgtk/src/gtkbindings.lisp:1.1.1.1	Mon Oct 27 14:14:55 2003
+++ lgtk/src/gtkbindings.lisp	Fri Oct 31 05:52:52 2003
@@ -17,11 +17,15 @@
 (defun rbooltrans (x)
   (if (/= x 0) t nil))
 
-(defclass gslist (simple-capsule) ())
+'(defclass gslist (simple-capsule) ())
 
-(defun gslist-capsule (obj)
+'(defun gslist-capsule (obj)
   (make-instance 'gslist :contents obj))
 
+(defclass gslist (sapcapsule) ())
+
+(def-encapsulator gslist-encap gslist)
+
 ;; For types where nil is acceptable as an object
 (defun contents-nil (obj)
   (cond ((null obj) obj)
@@ -36,7 +40,7 @@
 
   (gslist
    :in 'contents-nil
-   :out 'gslist-capsule
+   :out 'gslist-encap
    :alien '(* t))
 
   (gtkwindowtype
@@ -149,6 +153,10 @@
 (def-binding "gtk_radio_button_new_with_mnemonic_from_widget"
   (gtkradiobutton (gtkradiobutton group)
 		  (c-string msg)))
+
+(def-binding "gtk_radio_button_get_group"
+  (gslist (gtkradiobutton obj))
+  :after (lambda (x) (gcconnect obj x) x))
 
 (def-binding "gtk_toggle_button_get_active"
   (gboolean (gtktogglebutton wid)))


Index: lgtk/src/gtkclasshierarchy.lisp
diff -u lgtk/src/gtkclasshierarchy.lisp:1.1.1.1 lgtk/src/gtkclasshierarchy.lisp:1.2
--- lgtk/src/gtkclasshierarchy.lisp:1.1.1.1	Mon Oct 27 14:15:07 2003
+++ lgtk/src/gtkclasshierarchy.lisp	Fri Oct 31 05:52:52 2003
@@ -38,7 +38,6 @@
 	 :initarg :meta
 	 :initform (find-class 'gtk-objmeta))))
 
-
 ;;;
 ;;; Here we import the complete gtk class hierarchy.
 ;;;
@@ -170,3 +169,4 @@
 
   ;; engage.
   (make-gtk-object-hierarchy))
+


Index: lgtk/src/gtklisp.lisp
diff -u lgtk/src/gtklisp.lisp:1.1.1.1 lgtk/src/gtklisp.lisp:1.2
--- lgtk/src/gtklisp.lisp:1.1.1.1	Mon Oct 27 14:15:00 2003
+++ lgtk/src/gtklisp.lisp	Fri Oct 31 05:52:52 2003
@@ -115,14 +115,14 @@
 	  (let ((it (make-instance capsule
 				   :contents realw
 				   :nexus *gtkobjects*)))
-
-	    ;; We need at least one destroy call to know it's over and remove
-	    ;; all activable trace of the widget.
-	    (g-signal-connect it gtkdestroy
-			      #'dummy-func)
-
 	    it))))))
 
+;; We need at least one destroy call to know it's over and remove
+;; all activable trace of the widget.
+(defmethod initialize-instance :after ((it gtk-objcapsule) &key)
+  (g-signal-connect it
+		    gtkdestroy
+		    #'dummy-func))
 
 ;; Initialize.
 (eval-when (:load-toplevel :execute :compile-toplevel)


Index: lgtk/src/gtknexus.lisp
diff -u lgtk/src/gtknexus.lisp:1.1.1.1 lgtk/src/gtknexus.lisp:1.2
--- lgtk/src/gtknexus.lisp:1.1.1.1	Mon Oct 27 14:15:02 2003
+++ lgtk/src/gtknexus.lisp	Fri Oct 31 05:52:52 2003
@@ -13,7 +13,7 @@
 (defmethod destroy ((m gtk-objmeta))
   (debugf t "Here we go destroying a gtk-objmeta~%")
   (let ((standing (destroyers m)))
-    (cond (standing
+    (cond ((and standing (kill-on-gc-p m))
 	   (debugf t "It is still standing.~%")
 	   (mapcar #'destroy (callbacks m))
 	   (debugf t "Callbacks deallocated.~%")


Index: lgtk/src/nexus.lisp
diff -u lgtk/src/nexus.lisp:1.1.1.1 lgtk/src/nexus.lisp:1.2
--- lgtk/src/nexus.lisp:1.1.1.1	Mon Oct 27 14:15:05 2003
+++ lgtk/src/nexus.lisp	Fri Oct 31 05:52:53 2003
@@ -14,6 +14,7 @@
 	   :contents
 	   :metacapsule
 	   :metacapsule-identify
+	   :kill-on-gc-p
 	   :bag
 	   :meta
 	   :nexus
@@ -76,6 +77,10 @@
    (capsule :initarg :capsule
 	    :initform nil)
 
+   ;; Do we destroy this on GC? Good question. On by default.
+   (kill-on-gc-p :accessor kill-on-gc-p
+		 :initform T)
+
    ;; The nexus keeps a reference to it. Needed for bookkeeping.
    (nexus :accessor nexus
 	  :initarg :nexus
@@ -214,11 +219,12 @@
 	(setf (slot-value meta 'id) id)
 	id))))
 
-;; Standard destroy methods. Like this they would not make any sense.
+;; Standard destroy methods. Like this they would not make much sense.
 (defmethod destroy ((meta metacapsule))
   (let ((n (nexus meta)))
     (if n (remhash (metacapsule-identify meta)
 		   (table n)))
+
     (debugf t "Removed ~a from nexus ~a.~%" meta n)))
 
 (defmethod destroy ((meta idmeta))


Index: lgtk/src/widgets.lisp
diff -u lgtk/src/widgets.lisp:1.1.1.1 lgtk/src/widgets.lisp:1.2
--- lgtk/src/widgets.lisp:1.1.1.1	Mon Oct 27 14:15:08 2003
+++ lgtk/src/widgets.lisp	Fri Oct 31 05:52:53 2003
@@ -11,6 +11,8 @@
 	   :widcapsule
 	   :callbacks
 	   :destroyers
+	   :sapcapsule
+	   :sapmeta
 	   :resource
 	   :callback-resource
 	   :marker
@@ -30,6 +32,10 @@
 (in-package :widget-nexus)
 
 (defclass sapmeta (metacapsule) ())
+(defclass sapcapsule (weak-capsule)
+    ((meta :accessor meta
+	 :initarg :meta
+	 :initform (find-class 'sapmeta))))
 
 (defmethod metacapsule-identify ((m sapmeta))
   (alien-address (contents m)))