[lgtk-cvs] CVS update: lgtk/src/bindings.lisp lgtk/src/dynaslot.lisp lgtk/src/gtkclasshierarchy.lisp lgtk/src/gtklisp.lisp lgtk/src/nexus.lisp

[Mario Mommer]

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

Modified Files:
	bindings.lisp dynaslot.lisp gtkclasshierarchy.lisp 
	gtklisp.lisp nexus.lisp 
Log Message:
This change makes sure that (gtk) objects which are members of other
(gtk) objects do not get destroyed explicitly at gc time. Usually,
objects destroy their own members.

Date: Mon Nov 10 15:44:47 2003
Author: mmommer

Index: lgtk/src/bindings.lisp
diff -u lgtk/src/bindings.lisp:1.3 lgtk/src/bindings.lisp:1.4
--- lgtk/src/bindings.lisp:1.3	Wed Nov  5 16:20:41 2003
+++ lgtk/src/bindings.lisp	Mon Nov 10 15:44:47 2003
@@ -9,7 +9,7 @@
 (defpackage #:defbinding
   (:export #:def-binding #:def-bindings-types #:def-raw-binding
 	   #:set-aliens-package #:def-binding-type
-	   #:in-filter #:out-filter #:alien-type #:buildform)
+	   #:in-filter #:out-filter #:alien-type #:buildform #:_2-)
   (:use :common-lisp :clnexus-port))
 
 (in-package #:defbinding)
@@ -46,11 +46,27 @@
 (defun alien-type (symbol)
   (port-alien-type (binding-type-alien (get symbol 'binding-type))))
 
-(defun in-filter (symbol)
-  (binding-type-in (get symbol 'binding-type)))
-
-(defun out-filter (symbol)
-  (binding-type-out (get symbol 'binding-type)))
+(defun in-filter (symbol &rest args)
+  (let ((bto (binding-type-in (get symbol 'binding-type)))
+	(x (gensym "out-filter")))
+    (if bto
+	(if args
+	    `(lambda (,x)
+	       (,bto ,x , at args))
+	  bto)
+      (if args
+	  (error "filter NIL does not accept parameters (obviously).")))))
+
+(defun out-filter (symbol &rest args)
+  (let ((bto (binding-type-out (get symbol 'binding-type)))
+	(x (gensym "out-filter")))
+    (if bto
+	(if args
+	    `(lambda (,x)
+	       (,bto ,x , at args))
+	  bto)
+      (if args
+	  (error "filter NIL does not accept parameters (obviously).")))))
 
 (defun buildform (func arg)
   (if func (list func arg)


Index: lgtk/src/dynaslot.lisp
diff -u lgtk/src/dynaslot.lisp:1.1 lgtk/src/dynaslot.lisp:1.2
--- lgtk/src/dynaslot.lisp:1.1	Wed Nov  5 16:16:51 2003
+++ lgtk/src/dynaslot.lisp	Mon Nov 10 15:44:47 2003
@@ -58,7 +58,8 @@
 		      &key
 		      (reader t)
 		      (writer t)
-		      (export t))
+		      (export t)
+		      (destroy nil))
 		     req
 		   (let ((sname (intern (format nil "~A-~A" oname
 						(map 'string
@@ -67,7 +68,7 @@
 		     `(
 			,(if reader 
 			     `(defmethod ,sname ((x ,oname))
-				,(buildform (out-filter type)
+				,(buildform (out-filter type :destroy destroy)
 					    `(peek (contents x) ,offs
 						   ,(alien-type type)))))
 			,(if writer


Index: lgtk/src/gtkclasshierarchy.lisp
diff -u lgtk/src/gtkclasshierarchy.lisp:1.3 lgtk/src/gtkclasshierarchy.lisp:1.4
--- lgtk/src/gtkclasshierarchy.lisp:1.3	Wed Nov  5 12:49:56 2003
+++ lgtk/src/gtkclasshierarchy.lisp	Mon Nov 10 15:44:47 2003
@@ -55,7 +55,8 @@
 		(contents x)))))
 
   (defmacro def-encapsulator (name type)
-    `(defun ,name (x) (alien-encapsulate x ',type)))
+    `(defun ,name (x &key (destroy t))
+       (alien-encapsulate x ',type :destroy destroy)))
 
   (defun gencap (symb)
     (intern (format nil "~A-ENCAP" symb)))


Index: lgtk/src/gtklisp.lisp
diff -u lgtk/src/gtklisp.lisp:1.3 lgtk/src/gtklisp.lisp:1.4
--- lgtk/src/gtklisp.lisp:1.3	Wed Nov  5 12:49:56 2003
+++ lgtk/src/gtklisp.lisp	Mon Nov 10 15:44:47 2003
@@ -106,7 +106,7 @@
 
 	    it))))))
 
-(defun alien-encapsulate (realw capsule)
+(defun alien-encapsulate (realw capsule &key (destroy t))
   (let ((addrnum (alien-address realw)))
     (if (zerop addrnum) nil
       (let ((isit (gethash (alien-address realw)
@@ -114,7 +114,8 @@
 	(if isit (capsule isit)
 	  (let ((it (make-instance capsule
 				   :contents realw
-				   :nexus *gtkobjects*)))
+				   :nexus *gtkobjects*
+				   :destroy-real-object destroy)))
 	    it))))))
 
 ;; We need at least one destroy call to know it's over and remove


Index: lgtk/src/nexus.lisp
diff -u lgtk/src/nexus.lisp:1.3 lgtk/src/nexus.lisp:1.4
--- lgtk/src/nexus.lisp:1.3	Sun Nov  9 12:32:46 2003
+++ lgtk/src/nexus.lisp	Mon Nov 10 15:44:47 2003
@@ -79,7 +79,8 @@
 
    ;; Do we destroy this on GC? Good question. On by default.
    (destroy-real-object :accessor destroy-real-object
-		 :initform T)
+			:initarg :destroy-real-object
+			:initform T)
 
    ;; The nexus keeps a reference to it. Needed for bookkeeping.
    (nexus :accessor nexus
@@ -105,12 +106,13 @@
   (format t "~S ~S~%" a b))
 
 (defmethod initialize-instance :after ((c capsule)
-				       &key contents nexus)
+				       &key contents nexus destroy-real-object)
   (setf (meta c)
 	(make-instance (meta c)
 		       :contents contents
 		       :capsule c
-		       :nexus nexus)))
+		       :nexus nexus
+		       :destroy-real-object destroy-real-object)))
 
 ;; Only defined on metas, but the user is king.
 (defmethod destroy ((c capsule))