From 9dbe04ab1bd1ced86952eeab860a8bdb60b6660b Mon Sep 17 00:00:00 2001 From: Dmitry Kalyanov Date: Sun, 13 Sep 2009 03:23:15 +0400 Subject: [PATCH] Simplify Lisp image initialization and finalization process --- glib/cl-gtk2-glib.asd | 4 +--- glib/glib.lisp | 24 ++++++++++++++++++++++-- glib/gobject.object.high.lisp | 7 +++++++ glib/sbcl.lisp | 16 ---------------- gtk/cl-gtk2-gtk.asd | 1 - gtk/gtk.main_loop_events.lisp | 10 ++++++++-- gtk/gtk.misc.lisp | 2 +- gtk/sbcl.lisp | 14 -------------- 8 files changed, 39 insertions(+), 39 deletions(-) delete mode 100644 glib/sbcl.lisp delete mode 100644 gtk/sbcl.lisp diff --git a/glib/cl-gtk2-glib.asd b/glib/cl-gtk2-glib.asd index 28388f7..88a1241 100644 --- a/glib/cl-gtk2-glib.asd +++ b/glib/cl-gtk2-glib.asd @@ -34,7 +34,5 @@ (:file "gobject.cffi-callbacks") (:file "gobject.foreign-gobject-subclassing") - (:file "gobject.boxed") - - #+sbcl (:file "sbcl")) + (:file "gobject.boxed")) :depends-on (:cffi :trivial-garbage :iterate :bordeaux-threads :iterate :closer-mop)) \ No newline at end of file diff --git a/glib/glib.lisp b/glib/glib.lisp index 57c6e71..904e1ff 100644 --- a/glib/glib.lisp +++ b/glib/glib.lisp @@ -25,7 +25,8 @@ #:g-idle-add-full #:g-idle-add #:g-timeout-add-full - #:g-source-remove) + #:g-source-remove + #:at-finalize) (:documentation "Cl-gtk2-glib is wrapper for @a[http://library.gnome.org/devel/glib/]{GLib}.")) @@ -37,12 +38,28 @@ (defun register-initializer (key fn) (unless (gethash key *initializers-table*) (setf (gethash key *initializers-table*) t - *initializers* (nconc *initializers* (list fn)))))) + *initializers* (nconc *initializers* (list fn))))) + (defvar *finalizers-table* (make-hash-table :test 'equalp)) + (defvar *finalizers* nil) + (defun register-finalizer (key fn) + (unless (gethash key *finalizers-table*) + (setf (gethash key *finalizers-table*) t + *finalizers* (nconc *finalizers* (list fn)))))) (defun run-initializers () (iter (for fn in *initializers*) (funcall fn))) +(defun run-finalizers () + (iter (for fn in *finalizers*) + (funcall fn))) + +#+sbcl +(pushnew 'run-initializers sb-ext:*init-hooks*) + +#+sbcl +(pushnew 'run-finalizers sb-ext:*save-hooks*) + (defmacro at-init ((&rest keys) &body body) " @arg[keys]{list of expression} @@ -64,6 +81,9 @@ In this example, for every @code{class}, @code{(initialize-gobject-class-g-type `(progn (register-initializer (list ,@keys ',body) (lambda () ,@body)) ,@body)) +(defmacro at-finalize ((&rest keys) &body body) + `(register-finalizer (list ,@keys ',body) (lambda () ,@body))) + (eval-when (:compile-toplevel :load-toplevel :execute) (define-foreign-library glib (:unix (:or "libglib-2.0.so.0" "libglib-2.0.so")) diff --git a/glib/gobject.object.high.lisp b/glib/gobject.object.high.lisp index 099bf5f..66a0b63 100644 --- a/glib/gobject.object.high.lisp +++ b/glib/gobject.object.high.lisp @@ -23,6 +23,13 @@ (defvar *current-object-from-pointer* nil) (defvar *currently-making-object-p* nil) +(at-finalize () + (clrhash *foreign-gobjects-weak*) + (clrhash *foreign-gobjects-strong*) + (setf *current-creating-object* nil + *current-object-from-pointer* nil + *currently-making-object-p* nil)) + (defun ref-count (pointer) (foreign-slot-value (if (pointerp pointer) pointer (pointer pointer)) 'g-object-struct :ref-count)) diff --git a/glib/sbcl.lisp b/glib/sbcl.lisp deleted file mode 100644 index c5a670b..0000000 --- a/glib/sbcl.lisp +++ /dev/null @@ -1,16 +0,0 @@ -(in-package :glib) - -#+thread-support -(progn - (defun glib-stop-thread () - (setf *threads-initialized-p* nil)) - (pushnew 'glib-stop-thread sb-ext:*save-hooks*)) - -(defun map-inherited-classes (class fn) - (when (symbolp class) (setf class (find-class class))) - (when class - (funcall fn class) - (iter (for subclass in (closer-mop:class-direct-subclasses class)) - (map-inherited-classes subclass fn)))) - -(pushnew 'run-initializers sb-ext:*init-hooks*) diff --git a/gtk/cl-gtk2-gtk.asd b/gtk/cl-gtk2-gtk.asd index 38710c4..124c9e0 100644 --- a/gtk/cl-gtk2-gtk.asd +++ b/gtk/cl-gtk2-gtk.asd @@ -58,7 +58,6 @@ (:file "gtk.dialog.example") (:file "gtk.demo") - #+sbcl (:file "sbcl") (:module "demo-files" :pathname "demo" :components ((:static-file "demo1.glade") diff --git a/gtk/gtk.main_loop_events.lisp b/gtk/gtk.main_loop_events.lisp index d2809bc..961b357 100644 --- a/gtk/gtk.main_loop_events.lisp +++ b/gtk/gtk.main_loop_events.lisp @@ -17,7 +17,7 @@ (error "Cannot initialize Gtk+")) (foreign-free (mem-ref argv '(:pointer :string)))))) -(gtk-init) +(at-init () (gtk-init)) (defcfun gtk-main :void) @@ -25,11 +25,17 @@ (defvar *main-thread* nil) #+thread-support +(at-finalize () + (when (and *main-thread* (bt:thread-alive-p *main-thread*)) + (bt:destroy-thread *main-thread*) + (setf *main-thread* nil))) + +#+thread-support (defun ensure-gtk-main () (when (and *main-thread* (not (bt:thread-alive-p *main-thread*))) (setf *main-thread* nil)) (unless *main-thread* - (setf *main-thread* (bt:make-thread (lambda () (gtk:gtk-main)) :name "cl-gtk2 main thread")))) + (setf *main-thread* (bt:make-thread (lambda () (gtk-main)) :name "cl-gtk2 main thread")))) #+thread-support (defun join-main-thread () diff --git a/gtk/gtk.misc.lisp b/gtk/gtk.misc.lisp index 1dfa2cb..19c9720 100644 --- a/gtk/gtk.misc.lisp +++ b/gtk/gtk.misc.lisp @@ -53,6 +53,6 @@ (defmacro with-main-loop (&body body) `(progn ,@body - (gtk-main))) + (ensure-gtk-main))) (export 'with-main-loop) \ No newline at end of file diff --git a/gtk/sbcl.lisp b/gtk/sbcl.lisp deleted file mode 100644 index 59830eb..0000000 --- a/gtk/sbcl.lisp +++ /dev/null @@ -1,14 +0,0 @@ -(in-package :gtk) - -#+thread-support -(progn - (defun stop-main-thread-on-save () - (when (and *main-thread* (bt:thread-alive-p *main-thread*)) - (within-main-loop-and-wait (gtk-main-quit)) - (bt:destroy-thread *main-thread*) - (setf *main-thread* nil))) - (defun cl-gtk2-sbcl-init () - (gtk-init)) - (pushnew 'cl-gtk2-sbcl-init sb-ext:*init-hooks*) - (pushnew 'stop-main-thread-on-save sb-ext:*save-hooks*)) - -- 1.7.10.4