X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/1d1ff9a537adaf6e8d9e7896be480540d83589b4..4769576f381e72d2bc169a23e33b1c897f59e6e7:/glib/gtype.lisp diff --git a/glib/gtype.lisp b/glib/gtype.lisp index 4762a7a..add9c8e 100644 --- a/glib/gtype.lisp +++ b/glib/gtype.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtype.lisp,v 1.65 2007-10-17 14:33:50 espen Exp $ +;; $Id: gtype.lisp,v 1.69 2009-02-10 15:16:34 espen Exp $ (in-package "GLIB") @@ -128,15 +128,18 @@ (defun type-number-from-glib-name (name &optional (error-p t)) (defun type-from-glib-name (name) (type-from-number (type-number-from-glib-name name) t)) -(defun register-type (type id) +(defun type-registered-p (type) + (nth-value 1 (gethash type *lisp-type-to-type-number*))) + +(defun register-type (type id &optional (error-p t)) (cond - ((find-type-number type)) + ((type-registered-p type) (find-type-number type)) ((not id) (warn "Can't register type with no foreign id: ~A" type)) (t (pushnew (cons type id) *registered-types* :key #'car) (let ((type-number (typecase id - (string (type-number-from-glib-name id)) + (string (type-number-from-glib-name id error-p)) (symbol (funcall id))))) (setf (gethash type *lisp-type-to-type-number*) type-number) (setf (gethash type-number *type-number-to-lisp-type*) type) @@ -153,7 +156,7 @@ (defun reinitialize-all-types () (clrhash *type-number-to-lisp-type*) (type-init) ; initialize the glib type system (mapc #'(lambda (type) - (register-type (car type) (cdr type))) + (register-type (car type) (cdr type) nil)) *registered-types*) (mapc #'(lambda (type) (apply #'register-new-type type)) @@ -162,14 +165,11 @@ (defun reinitialize-all-types () (register-type-alias (car type) (cdr type))) *registered-type-aliases*)) -(pushnew 'reinitialize-all-types - #+cmu *after-save-initializations* - #+sbcl *init-hooks* - #+clisp custom:*init-hooks*) - #+cmu -(pushnew 'system::reinitialize-global-table ; we shouldn't have to do this? - *after-save-initializations*) +(asdf:install-init-hook 'system::reinitialize-global-table + *after-save-initializations*) ; we shouldn't need to do this? +(asdf:install-init-hook 'reinitialize-all-types) + (defun find-type-number (type &optional error-p) @@ -179,8 +179,13 @@ (defun find-type-number (type &optional error-p) (symbol (or (gethash type *lisp-type-to-type-number*) + (let ((class (find-class type nil))) + (when (and class (not (class-finalized-p class))) + (finalize-inheritance class) + (gethash type *lisp-type-to-type-number*))) (and error-p (error "Type not registered: ~A" type)))) - (class (find-type-number (class-name type) error-p)))) + (class + (find-type-number (class-name type) error-p)))) (defun type-from-number (type-number &optional error) (multiple-value-bind (type found) @@ -214,6 +219,14 @@ (defun type-number-of (object) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *type-initializers* ()) + + (defun library-filename (system library) + (let ((component (asdf:find-component (asdf:find-system system) library))) + (etypecase component + (asdf:shared-object + (first (asdf:output-files (make-instance 'asdf:compile-op) component))) + (asdf:library (asdf:component-pathname component))))) + (defun %find-types-in-library (pathname prefixes ignore) (let ((outname (tmpname "types"))) (unwind-protect @@ -263,20 +276,25 @@ (defun %find-types-in-library (pathname prefixes ignore) (delete-file outname))))) +(defun car-eq-p (ob1 ob2) + (eq (car ob1) (car ob2))) + (defmacro init-types-in-library (system library &key prefix ignore) - (let* ((filename (asdf:component-pathname (asdf:find-component (asdf:find-system system) library))) + (let* ((filename (library-filename system library)) (names (%find-types-in-library filename prefix ignore))) `(progn - ,@(mapcar #'(lambda (name) - `(progn - (defbinding (,(intern name) ,name) () type-number) - (,(intern name)) - (pushnew ',(intern name) *type-initializers*))) - names)))) + ,@(mapcar + #'(lambda (name) + `(progn + (defbinding (,(intern name) ,name) () type-number) + (,(intern name)) + (pushnew (cons ',(intern name) ,filename) *type-initializers* + :test #'car-eq-p))) + names)))) (defun find-type-init-function (type-number) (loop - for type-init in *type-initializers* + for (type-init) in *type-initializers* when (= type-number (funcall type-init)) do (return type-init))) @@ -330,6 +348,8 @@ (defun register-new-type (type parent &optional foreign-name) ;;;; Metaclass for subclasses of ginstance +(defvar *referenced-ginstance-classes* ()) + (eval-when (:compile-toplevel :load-toplevel :execute) (defclass ginstance-class (proxy-class) ((gtype :initarg :gtype :initform nil :reader ginstance-class-gtype)))) @@ -353,27 +373,28 @@ (defmethod finalize-inheritance ((class ginstance-class)) (super (most-specific-proxy-superclass class)) (gtype (or (first (ginstance-class-gtype class)) - (default-alien-type-name class-name))) - (type-number - (or - (find-type-number class-name) - (let ((type-number - (if (or - (symbolp gtype) - (type-number-from-glib-name gtype nil)) - (register-type class-name gtype) - (register-new-type class-name (class-name super) gtype)))) - (type-class-ref type-number) - type-number)))) + (default-alien-type-name class-name)))) + (unless (type-registered-p class-name) + (type-class-ref + (if (or (symbolp gtype) (type-number-from-glib-name gtype nil)) + (register-type class-name gtype) + (register-new-type class-name (class-name super) gtype))) + (push class-name *referenced-ginstance-classes*)) #+nil (when (and - (supertype type-number) - (not (eq (class-name super) (supertype type-number)))) + (supertype (find-type-number class)) + (not (eq (class-name super) (supertype (find-type-number class))))) (warn "Super class mismatch between CLOS and GObject for ~A" class-name))) (update-size class)) #-clisp(call-next-method)) +(defun reinitialize-ginstance-classes () + (mapc #'type-class-ref *referenced-ginstance-classes*)) + +(asdf:install-init-hook 'reinitialize-ginstance-classes) + + (defmethod shared-initialize ((class ginstance-class) names &rest initargs) (declare (ignore names initargs)) @@ -413,7 +434,7 @@ (defmethod make-proxy-instance :around ((class ginstance-class) location (unless (zerop type-number) (find-known-class (type-parent type-number)))))) (find-known-class (%type-number-of-ginstance location))))) - ;; Note that chancing the class argument should not alter "the + ;; Note that changing the class argument must not alter "the ;; ordered set of applicable methods" as specified in the ;; Hyperspec (if class @@ -583,64 +604,88 @@ (defun sort-types-topologicaly (unsorted) t)))))) -(defun expand-type-definitions (prefix &optional args) +(defun expand-type-definitions (type-list &optional args) (flet ((type-options (type-number) (let ((name (find-foreign-type-name type-number))) (cdr (assoc name args :test #'string=))))) - (let ((type-list - (delete-if - #'(lambda (type-number) - (let ((name (find-foreign-type-name type-number))) - (or - (getf (type-options type-number) :ignore) - (find-if - #'(lambda (options) - (and - (string-prefix-p (first options) name) - (getf (cdr options) :ignore-prefix) - (not (some - #'(lambda (exception) - (string= name exception)) - (getf (cdr options) :except))))) - args)))) - (find-types prefix)))) - - (dolist (type-number type-list) - (let ((name (find-foreign-type-name type-number))) - (register-type - (getf (type-options type-number) :type (default-type-name name)) - (register-type-as type-number)))) - - ;; This is needed for some unknown reason to get type numbers right - (mapc #'find-type-dependencies type-list) - - (let ((sorted-type-list - #+clisp (mapcar #'list type-list) - #-clisp - (sort-types-topologicaly - (mapcar - #'(lambda (type) - (cons type (find-type-dependencies type (type-options type)))) - type-list)))) - `(progn - ,@(mapcar - #'(lambda (pair) - (destructuring-bind (type . forward-p) pair - (expand-type-definition type forward-p (type-options type)))) - sorted-type-list) - ,@(mapcar - #'(lambda (pair) - (destructuring-bind (type . forward-p) pair - (when forward-p - (expand-type-definition type nil (type-options type))))) - sorted-type-list)))))) + (setq type-list + (delete-if + #'(lambda (type-number) + (let ((name (find-foreign-type-name type-number))) + (or + (getf (type-options type-number) :ignore) + (find-if + #'(lambda (options) + (and + (string-prefix-p (first options) name) + (getf (cdr options) :ignore-prefix) + (not (some + #'(lambda (exception) + (string= name exception)) + (getf (cdr options) :except))))) + args)))) + type-list)) + + (dolist (type-number type-list) + (let ((name (find-foreign-type-name type-number))) + (register-type + (getf (type-options type-number) :type (default-type-name name)) + (register-type-as type-number)))) + + ;; This is needed for some unknown reason to get type numbers right + (mapc #'find-type-dependencies type-list) + + (let ((sorted-type-list + #+clisp (mapcar #'list type-list) + #-clisp + (sort-types-topologicaly + (mapcar + #'(lambda (type) + (cons type (find-type-dependencies type (type-options type)))) + type-list)))) + `(progn + ,@(mapcar + #'(lambda (pair) + (destructuring-bind (type . forward-p) pair + (expand-type-definition type forward-p (type-options type)))) + sorted-type-list) + ,@(mapcar + #'(lambda (pair) + (destructuring-bind (type . forward-p) pair + (when forward-p + (expand-type-definition type nil (type-options type))))) + sorted-type-list))))) + +(defun expand-types-with-prefix (prefix args) + (expand-type-definitions (find-types prefix) args)) + +(defun expand-types-in-library (system library args) + (let* ((filename (library-filename system library)) + (types (loop + for (type-init . %filename) in *type-initializers* + when (equal filename %filename) + collect (funcall type-init)))) + (expand-type-definitions types args))) + +(defun list-types-in-library (system library) + (let ((filename (library-filename system library))) + (loop + for (type-init . %filename) in *type-initializers* + when (equal filename %filename) + collect type-init))) (defmacro define-types-by-introspection (prefix &rest args) - (expand-type-definitions prefix args)) + (expand-types-with-prefix prefix args)) (defexport define-types-by-introspection (prefix &rest args) - (list-autoexported-symbols (expand-type-definitions prefix args))) + (list-autoexported-symbols (expand-types-with-prefix prefix args))) + +(defmacro define-types-in-library (system library &rest args) + (expand-types-in-library system library args)) + +(defexport define-types-in-library (system library &rest args) + (list-autoexported-symbols (expand-types-in-library system library args))) ;;;; Initialize all non static types in GObject