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 ,@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 ,@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))