- lgtk-cvs@common-lisp.net - mailman3.common-lisp.net

[lgtk-cvs] CVS update: lgtk/INSTALL.txt
by Mario Mommer 05 Dec '03

05 Dec '03

Update of /project/lgtk/cvsroot/lgtk In directory common-lisp.net:/tmp/cvs-serv30934 Modified Files: Tag: sbcl-port INSTALL.txt Log Message: Added instructions for installing under SBCL. Date: Fri Dec 5 12:23:26 2003 Author: mmommer Index: lgtk/INSTALL.txt diff -u lgtk/INSTALL.txt:1.2 lgtk/INSTALL.txt:1.2.4.1 --- lgtk/INSTALL.txt:1.2 Wed Oct 29 12:20:44 2003 +++ lgtk/INSTALL.txt Fri Dec 5 12:23:26 2003 @@ -1,11 +1,17 @@ How to install lgtk, a gtk+ interface for Common Lisp --------------------------------------------------------- -You need the following things: +If you want to use lgtk with SBCL, read + + http://www.caddr.com/macho/archives/clump/2003-12/360.html + +for instructons. + +Otherwise, you will need the following things: * The source code. - * Preferably, CMUCL 19a. + * Preferably, CMUCL 19a, or an SBCL with callback support. Alternatively, you need a CMUCL 18e core with callback support. You should grab a copy of Helmut Eller's callback.lisp

1 0

[lgtk-cvs] CVS update: lgtk/src/dynaslot.lisp lgtk/src/gtklisp.lisp lgtk/src/gtknexus.lisp lgtk/src/port.lisp
by Mario Mommer 05 Dec '03

05 Dec '03

Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv13531/src Modified Files: Tag: sbcl-port dynaslot.lisp gtklisp.lisp gtknexus.lisp port.lisp Log Message: Applied patch by Damien Diederen <diederen (at) swing (dot) be>. It should run on sbcl. Date: Fri Dec 5 11:55:08 2003 Author: mmommer Index: lgtk/src/dynaslot.lisp diff -u lgtk/src/dynaslot.lisp:1.3 lgtk/src/dynaslot.lisp:1.3.4.1 --- lgtk/src/dynaslot.lisp:1.3 Mon Nov 10 16:44:07 2003 +++ lgtk/src/dynaslot.lisp Fri Dec 5 11:55:08 2003 @@ -117,6 +117,7 @@ (car req) (caddr req) off)) offsl reqs)))))))) +#+cmu (defmacro peek (base off type) `(alien:deref (alien:sap-alien @@ -125,12 +126,31 @@ (system:sap-int (alien:alien-sap ,base)))) (* ,type)))) +#+sbcl +(defmacro peek (base off type) + `(sb-alien:deref + (sb-alien:sap-alien + (sb-sys:int-sap + (+ ,off + (sb-sys:sap-int (sb-alien:alien-sap ,base)))) + (* ,type)))) + +#+cmu (defmacro poke (base off type value) `(setf (alien:deref (alien:sap-alien (system:int-sap (+ ,off (system:sap-int (alien:alien-sap ,base)))) + (* ,type))) ,value)) + +#+sbcl +(defmacro poke (base off type value) + `(setf (sb-alien:deref + (sb-alien:sap-alien + (sb-sys:int-sap + (+ ,off + (sb-sys:sap-int (sb-alien:alien-sap ,base)))) (* ,type))) ,value)) ;; This is how this should be used. Index: lgtk/src/gtklisp.lisp diff -u lgtk/src/gtklisp.lisp:1.4 lgtk/src/gtklisp.lisp:1.4.4.1 --- lgtk/src/gtklisp.lisp:1.4 Mon Nov 10 15:44:47 2003 +++ lgtk/src/gtklisp.lisp Fri Dec 5 11:55:08 2003 @@ -140,7 +140,9 @@ (defun gtk-init () (when (not *gtk-init*) (let ((i 0)) - (gtk-aliens::|gtk_init| i (system:int-sap 0))) + (gtk-aliens::|gtk_init| i + #+cmu (system:int-sap 0) + #+sbcl (sb-sys:int-sap 0))) (setf *gtk-init* t))) (gtk-init)) @@ -173,8 +175,9 @@ (funcall *sigint-handler* a b c))))) (setf *sigint-handler* - (system:enable-interrupt unix:SIGINT #'my-handler)) - + #+cmu (system:enable-interrupt unix:SIGINT #'my-handler) + #+sbcl (sb-sys:enable-interrupt sb-unix:SIGINT #'my-handler)) + (let ((*in-main* t)) (gtk-aliens::|gtk_main|)) @@ -186,7 +189,8 @@ (throw 'common-lisp::top-level-catcher nil))) ;; When unwinding - (system:enable-interrupt unix:SIGINT *sigint-handler*) + #+cmu (system:enable-interrupt unix:SIGINT *sigint-handler*) + #+sbcl (sb-sys:enable-interrupt sb-unix:SIGINT *sigint-handler*) (setf *sigint-handler* nil)))) ;; So far, so good. @@ -205,12 +209,16 @@ (defun schedule-visual-gc () (when (not (or *visual-gc-scheduled* *main-active*)) (setf *visual-gc-scheduled* t) + #+cmu (mp:make-process #'(lambda () (sleep 1) (unless *main-active* (live-for-1msec)) - (setf *visual-gc-scheduled* nil))))) + (setf *visual-gc-scheduled* nil))) + ;; Need to provide SBCL alternative here. -dd + #+sbcl + t)) (eval-when (:load-toplevel) (run-after-gc #'schedule-visual-gc)) Index: lgtk/src/gtknexus.lisp diff -u lgtk/src/gtknexus.lisp:1.4 lgtk/src/gtknexus.lisp:1.4.4.1 --- lgtk/src/gtknexus.lisp:1.4 Sun Nov 9 12:32:46 2003 +++ lgtk/src/gtknexus.lisp Fri Dec 5 11:55:08 2003 @@ -197,15 +197,22 @@ r)))) ;; Trampolines -(defcallback gtk-standard-decoy (c-call:void (w (* t)) (cookie c-call:int)) +(defcallback gtk-standard-decoy + #+cmu (c-call:void (w (* t)) (cookie c-call:int)) + #+sbcl (sb-alien:void (w (* t)) (cookie sb-alien:int)) (%standard-handler w cookie)) -(defcallback gtk-destroy-decoy (c-call:void (w (* t)) (cookie c-call:int)) +(defcallback gtk-destroy-decoy + #+cmu (c-call:void (w (* t)) (cookie c-call:int)) + #+sbcl (sb-alien:void (w (* t)) (cookie sb-alien:int)) (%destroy-handler w cookie)) -(defcallback gtk-evhandling-decoy (c-call:int - (w (* t)) (ev (* t)) (cookie c-call:int)) +(defcallback gtk-evhandling-decoy + #+cmu (c-call:int (w (* t)) (ev (* t)) (cookie c-call:int)) + #+sbcl (sb-alien:int (w (* t)) (ev (* t)) (cookie sb-alien:int)) (%event-handler w ev cookie)) -(defcallback %gtk-itc-handler (c-call:int (id c-call:int)) +(defcallback %gtk-itc-handler + #+cmu (c-call:int (id c-call:int)) + #+sbcl (sb-alien:int (id sb-alien:int)) (%itc-handler id)) Index: lgtk/src/port.lisp diff -u lgtk/src/port.lisp:1.3 lgtk/src/port.lisp:1.3.4.1 --- lgtk/src/port.lisp:1.3 Wed Oct 29 12:20:45 2003 +++ lgtk/src/port.lisp Fri Dec 5 11:55:08 2003 @@ -44,6 +44,25 @@ (* *) (t t))) +#+sbcl +(defparameter *c-types* + '((:char sb-alien:char) + (:short sb-alien:short) + (:ushort sb-alien:unsigned-short) + (:int sb-alien:int) + (:uint sb-alien:unsigned-int) + (:long sb-alien:long) + (:ulong sb-alien:unsigned-long) + (:double sb-alien:double) + (:float sb-alien:float) + + (:c-string sb-alien:c-string) + + (:void sb-alien:void) + (:voidptr (* t)) + (* *) + (t t))) + (defun port-alien-type (key) (let ((it (cond ((atom key) (cadr (assoc key *c-types*))) (t (mapcar #'port-alien-type key))))) @@ -52,23 +71,30 @@ ;; Get the actual pointer number (defun alien-address (it) - #+cmu (system:sap-int (alien:alien-sap it))) + #+cmu (system:sap-int (alien:alien-sap it)) + #+sbcl (sb-sys:sap-int (sb-alien:alien-sap it))) (defmacro def-alien-routine (&rest stuff) - #+cmu `(alien:def-alien-routine ,@stuff)) + #+cmu `(alien:def-alien-routine ,@stuff) + #+sbcl `(sb-alien:def-alien-routine ,@stuff)) ;;; GC magic #+cmu (defvar *weak-pointer-type* 'ext:weak-pointer) +#+sbcl (defvar *weak-pointer-type* 'sb-ext:weak-pointer) (defun finalize (fun obj) - #+cmu (ext:finalize fun obj)) + #+cmu (ext:finalize fun obj) + #+sbcl (sb-ext:finalize fun obj)) (defun make-weak-pointer (obj) - #+cmu (ext:make-weak-pointer obj)) + #+cmu (ext:make-weak-pointer obj) + #+sbcl (sb-ext:make-weak-pointer obj)) (defun weak-pointer-value (obj) - #+cmu (ext:weak-pointer-value obj)) + #+cmu (ext:weak-pointer-value obj) + #+sbcl (sb-ext:weak-pointer-value obj)) (defun run-after-gc (fun) - (pushnew fun ext:*after-gc-hooks*)) \ No newline at end of file + #+cmu (pushnew fun ext:*after-gc-hooks*) + #+sbcl (pushnew fun sb-ext:*after-gc-hooks*))

1 0

[lgtk-cvs] CVS update: lgtk/lgtk.asd
by Mario Mommer 05 Dec '03

05 Dec '03

Update of /project/lgtk/cvsroot/lgtk In directory common-lisp.net:/tmp/cvs-serv13531 Modified Files: Tag: sbcl-port lgtk.asd Log Message: Applied patch by Damien Diederen <diederen (at) swing (dot) be>. It should run on sbcl. Date: Fri Dec 5 11:55:07 2003 Author: mmommer Index: lgtk/lgtk.asd diff -u lgtk/lgtk.asd:1.7 lgtk/lgtk.asd:1.7.4.1 --- lgtk/lgtk.asd:1.7 Sun Nov 9 12:32:45 2003 +++ lgtk/lgtk.asd Fri Dec 5 11:55:07 2003 @@ -6,7 +6,7 @@ ;; advertising clause"). See the file COPYING for details. (defpackage #:lgtk-asd - (:use :cl :asdf)) + (:use :cl :asdf #+cmu :ext #+sbcl :sb-ext #+sbcl :sb-alien)) (in-package :lgtk-asd) @@ -33,12 +33,13 @@ ;; Get the list of libraries. (defun get-gtk-libs-list () - (let ((prc (ext:run-program "pkg-config" '("--libs" "gtk+-2.0") + (let ((prc (run-program "pkg-config" '("--libs" "gtk+-2.0") + :search t :output :stream))) (if (not prc) (error "Could not run #\"pckg-config!") - (let ((str (ext:process-output prc)) - (ecode (ext:process-exit-code prc))) + (let ((str (process-output prc)) + (ecode (process-exit-code prc))) (if (not (eql ecode 0)) (error "Could not find gtk+-2.0") (remove-if ;; Remove options which do not specify a lib @@ -48,12 +49,13 @@ (splitatspc (read-line str)))))))) (defun get-gtk-cflags-list () - (let ((prc (ext:run-program "pkg-config" '("--cflags" "gtk+-2.0") + (let ((prc (run-program "pkg-config" '("--cflags" "gtk+-2.0") + :search t :output :stream))) (if (not prc) (error "Could not run #\"pckg-config!") - (let ((str (ext:process-output prc)) - (ecode (ext:process-exit-code prc))) + (let ((str (process-output prc)) + (ecode (process-exit-code prc))) (if (not (eql ecode 0)) (error "Could not find gtk+-2.0") (read-line str)))))) @@ -78,8 +80,8 @@ (defmethod perform ((o load-op) (c gtk-libs-handle)) (setf *source-dir* (pathname-directory (component-pathname c))) - (ext:load-foreign (namestring (car (output-files o c))) - :libraries *gtklibs*)) + (load-foreign (namestring (car (output-files o c))) + :libraries *gtklibs*)) (defsystem lgtk :name "lgtk"

1 0

[lgtk-cvs] CVS update: lgtk/examples/entry.lisp
by Mario Mommer 11 Nov '03

11 Nov '03

Update of /project/lgtk/cvsroot/lgtk/examples In directory common-lisp.net:/tmp/cvs-serv30646/examples Added Files: entry.lisp Log Message: Added text entries. Also added an example. Date: Tue Nov 11 16:41:54 2003 Author: mmommer

1 0

[lgtk-cvs] CVS update: lgtk/src/gtkbindings.lisp
by Mario Mommer 11 Nov '03

11 Nov '03

Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv30646/src Modified Files: gtkbindings.lisp Log Message: Added text entries. Also added an example. Date: Tue Nov 11 16:41:54 2003 Author: mmommer Index: lgtk/src/gtkbindings.lisp diff -u lgtk/src/gtkbindings.lisp:1.4 lgtk/src/gtkbindings.lisp:1.5 --- lgtk/src/gtkbindings.lisp:1.4 Wed Nov 5 16:18:19 2003 +++ lgtk/src/gtkbindings.lisp Tue Nov 11 16:41:54 2003 @@ -183,9 +183,27 @@ (void (gtktogglebutton wid) (gboolean active))) +(def-binding "gtk_entry_new" + (gtkentry)) + +(def-binding "gtk_entry_set_text" + (void (GtkEntry entry) + (c-string text))) + +(def-binding "gtk_entry_get_text" + (c-string (GtkEntry entry))) + +(def-binding "gtk_editable_set_editable" + (void (GtkEntry entry) + (gboolean active))) + +(def-binding "gtk_entry_set_visibility" + (void (GtkEntry entry) + (gboolean visible))) + (def-binding "gtk_arrow_new" - (GtkWidget (GtkArrowType arrow_type) - (GtkShadowType shadow_type))) + (gtkarrow (GtkArrowType arrow_type) + (GtkShadowType shadow_type))) (def-binding "gtk_arrow_set" (void (GtkArrow arrow)

1 0

[lgtk-cvs] CVS update: lgtk/lgtk-examples.asd
by Mario Mommer 11 Nov '03

11 Nov '03

Update of /project/lgtk/cvsroot/lgtk In directory common-lisp.net:/tmp/cvs-serv30646 Modified Files: lgtk-examples.asd Log Message: Added text entries. Also added an example. Date: Tue Nov 11 16:41:52 2003 Author: mmommer Index: lgtk/lgtk-examples.asd diff -u lgtk/lgtk-examples.asd:1.3 lgtk/lgtk-examples.asd:1.4 --- lgtk/lgtk-examples.asd:1.3 Mon Nov 10 16:47:34 2003 +++ lgtk/lgtk-examples.asd Tue Nov 11 16:41:51 2003 @@ -25,7 +25,8 @@ (:file "radio-buttons") (:file "toggle-button") (:file "tables-hw") - (:file "dialog")))) + (:file "dialog") + (:file "entry")))) :depends-on (:lgtk))

1 0

[lgtk-cvs] CVS update: lgtk/lgtk-examples.asd
by Mario Mommer 10 Nov '03

10 Nov '03

Update of /project/lgtk/cvsroot/lgtk In directory common-lisp.net:/tmp/cvs-serv21561 Modified Files: lgtk-examples.asd Log Message: Added the dialog example. Date: Mon Nov 10 16:47:34 2003 Author: mmommer Index: lgtk/lgtk-examples.asd diff -u lgtk/lgtk-examples.asd:1.2 lgtk/lgtk-examples.asd:1.3 --- lgtk/lgtk-examples.asd:1.2 Wed Oct 29 12:43:37 2003 +++ lgtk/lgtk-examples.asd Mon Nov 10 16:47:34 2003 @@ -24,7 +24,8 @@ (:file "check-button") (:file "radio-buttons") (:file "toggle-button") - (:file "tables-hw")))) + (:file "tables-hw") + (:file "dialog")))) :depends-on (:lgtk))

1 0

[lgtk-cvs] CVS update: lgtk/examples/dialog.lisp
by Mario Mommer 10 Nov '03

10 Nov '03

Update of /project/lgtk/cvsroot/lgtk/examples In directory common-lisp.net:/tmp/cvs-serv20662 Modified Files: dialog.lisp Log Message: The dialog example is now complete. Date: Mon Nov 10 16:45:24 2003 Author: mmommer Index: lgtk/examples/dialog.lisp diff -u lgtk/examples/dialog.lisp:1.1 lgtk/examples/dialog.lisp:1.2 --- lgtk/examples/dialog.lisp:1.1 Wed Nov 5 16:19:42 2003 +++ lgtk/examples/dialog.lisp Mon Nov 10 16:45:23 2003 @@ -3,35 +3,39 @@ (use-package :gtk) (defun dialog () - (let ((dialog (gtk-dialog-new)) - (button1 (gtk-button-new-with-label "Ok...")) - (button2 (gtk-button-new-with-label "Well...")) - (button3 (gtk-button-new-with-label "Ehm...")) - (frame (gtk-frame-new "I want your opinion:")) - (label (gtk-label-new "Aren't dialogs cool?"))) - - (gtk-box-pack-start - (gtkdialog-action_area dialog) - button1) - - (gtk-box-pack-start - (gtkdialog-action_area dialog) - button2) - - (gtk-box-pack-start - (gtkdialog-action_area dialog) - button3) - - (gtk-box-pack-start - (gtkdialog-vbox dialog) - frame) - - (gtk-container-add - frame label) + (labels ((its-over (&rest args) (declare (ignore args)) + (gtk-main-quit))) + (let ((dialog (gtk-dialog-new)) + (frame (gtk-frame-new "I want your opinion:")) + (label (gtk-label-new "Aren't dialogs cool?")) + (button1 (gtk-button-new-with-label "Ok...")) + (button2 (gtk-button-new-with-label "Well...")) + (button3 (gtk-button-new-with-label "Ehm..."))) + + (gtk-box-pack-start + (gtkdialog-action-area dialog) + button1) + + (gtk-box-pack-start + (gtkdialog-action-area dialog) + button2) + + (gtk-box-pack-start + (gtkdialog-action-area dialog) + button3) + + (gtk-box-pack-start + (gtkdialog-vbox dialog) + frame) + + (gtk-container-add + frame label) - (gtk-container-set-border-width frame 10) - (gtk-widget-set-size-request label 30 30) + (gtk-container-set-border-width frame 10) + (gtk-widget-set-size-request label 30 30) - (gtk-widget-show-all dialog) + (g-signal-connect dialog gtkdestroy #'its-over) - (gtk-main))) \ No newline at end of file + (gtk-widget-show-all dialog) + + (gtk-main)))) \ No newline at end of file

1 0

[lgtk-cvs] CVS update: lgtk/src/dynaslot.lisp
by Mario Mommer 10 Nov '03

10 Nov '03

Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv19310 Modified Files: dynaslot.lisp Log Message: Slot "a_slot" becomes now a-slot in lisp. Added a :lisp-name option to ADD-ALIEN-SLOTS, to be able to customize this. Date: Mon Nov 10 16:44:07 2003 Author: mmommer Index: lgtk/src/dynaslot.lisp diff -u lgtk/src/dynaslot.lisp:1.2 lgtk/src/dynaslot.lisp:1.3 --- lgtk/src/dynaslot.lisp:1.2 Mon Nov 10 15:44:47 2003 +++ lgtk/src/dynaslot.lisp Mon Nov 10 16:44:07 2003 @@ -59,12 +59,14 @@ (reader t) (writer t) (export t) - (destroy nil)) + (destroy nil) + (lisp-name nil)) req - (let ((sname (intern (format nil "~A-~A" oname - (map 'string - #'char-upcase - name))))) + (let ((sname (if lisp-name lisp-name + (intern (format nil "~A-~A" oname + (map 'string + #'char-upcase + (_2- name))))))) `( ,(if reader `(defmethod ,sname ((x ,oname))

1 0

[lgtk-cvs] CVS update: lgtk/src/bindings.lisp lgtk/src/dynaslot.lisp lgtk/src/gtkclasshierarchy.lisp lgtk/src/gtklisp.lisp lgtk/src/nexus.lisp
by Mario Mommer 10 Nov '03

10 Nov '03

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

1 0