X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/af338f4a78fec3685e39ce00bcc4cd891e7c0b60..4769576f381e72d2bc169a23e33b1c897f59e6e7:/glib/gtype.lisp diff --git a/glib/gtype.lisp b/glib/gtype.lisp index 0de8bbd..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.60 2007-01-12 10:32:43 espen Exp $ +;; $Id: gtype.lisp,v 1.69 2009-02-10 15:16:34 espen Exp $ (in-package "GLIB") @@ -30,7 +30,10 @@ (use-prefix "g") (defbinding type-init () nil) (type-init) -(deftype type-number () 'unsigned-long) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defbinding (bitsize-of-gtype "bitsize_of_gtype") () unsigned-int)) + +(deftype type-number () `(unsigned-byte ,(bitsize-of-gtype))) (deftype gtype () 'symbol) @@ -125,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) @@ -150,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)) @@ -159,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) @@ -176,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) @@ -201,61 +209,92 @@ (defbinding (find-foreign-type-name "g_type_name") (type) (copy-of string) (defun type-number-of (object) (find-type-number (type-of object) t)) +;; For #+(SBCL WIN32): +;; The first 2 lines of the output from "pexports" are: +;; LIBRARY XXX.dll +;; EXPORTS +;; We don't do anything to skip these 2 lines because they won't pass the +;; WHEN (AND ...) in the LOOP +;; - cph 19-May-2007 + (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 ((process - (run-program - "/usr/bin/nm" - #+clisp :arguments - (list #-darwin"--defined-only" #-darwin"-D" "-g" #+darwin"-f" - #+darwin"-s" #+darwin"__TEXT" #+darwin"__text" - (namestring (truename pathname))) - :output :stream :wait nil))) + (let ((outname (tmpname "types"))) (unwind-protect - (loop - as line = (read-line - #+(or cmu sbcl) (process-output process) - #+clisp process - nil) - as symbol = (when line - (let ((pos (position #\Space line :from-end t))) - #-darwin(subseq line (1+ pos)) - #+darwin - (when (char= (char line (1- pos)) #\T) - (subseq line (+ pos 2))))) - while line - when (and - symbol (> (length symbol) 9) - (not (char= (char symbol 0) #\_)) - (or - (not prefixes) - (some #'(lambda (prefix) - (and - (> (length symbol) (length prefix)) - (string= prefix symbol :end2 (length prefix)))) - (mklist prefixes))) - (string= "_get_type" symbol :start2 (- (length symbol) 9)) - (not (member symbol ignore :test #'string=))) - collect symbol) - (#+(or cmu sbcl)process-close - #+clisp close - process))))) - - -(defmacro init-types-in-library (filename &key prefix ignore) - (let ((names (%find-types-in-library filename prefix ignore))) + (let ((asdf::*verbose-out* nil)) + #-win32 + (asdf:run-shell-command "nm ~A ~A > ~A" + #-darwin "--defined-only --dynamic --extern-only" + #+darwin "-f -s __TEXT __text" + (namestring (truename pathname)) outname) + ;; Note about win32 port: + ;; 1. (TRUENAME PATHNAME) will bomb. + ;; 2. either + ;; pexports "d:\\whatever\\bin\\zlib1.dll" + ;; or + ;; pexports d:/whatever/bin/zlib1.dll + ;; anything else will bomb. this is why ~S is used below. + #+win32 + (asdf:run-shell-command "pexports ~S > ~A" + (namestring pathname) outname) + + (with-open-file (output outname) + (loop + as line = (read-line output nil) + as symbol = (when line + #-win32 + (let ((pos (position #\space line :from-end t))) + #-darwin(subseq line (1+ pos)) + #+darwin + (when (char= (char line (1- pos)) #\T) + (subseq line (+ pos 2)))) + #+win32 + (subseq line 0 (1- (length line)))) + while line + when (and + symbol (> (length symbol) 9) + (not (char= (char symbol 0) #\_)) + (or + (not prefixes) + (some #'(lambda (prefix) + (and + (> (length symbol) (length prefix)) + (string= prefix symbol :end2 (length prefix)))) + (mklist prefixes))) + (string= "_get_type" symbol :start2 (- (length symbol) 9)) + (not (member symbol ignore :test #'string=))) + collect symbol))) + (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 (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))) @@ -309,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)))) @@ -332,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)) @@ -392,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 @@ -416,8 +458,8 @@ (register-type 'long "glong") (register-type 'unsigned-long "gulong") (register-type 'single-float "gfloat") (register-type 'double-float "gdouble") -(register-type 'pathname "gchararray") (register-type 'string "gchararray") +(register-type-alias 'pathname 'string) ;;;; Introspection of type information @@ -510,7 +552,7 @@ (defun find-type-dependencies (type &optional options) ;; The argument is a list where each elements is on the form ;; (type . dependencies). This function will not handle indirect -;; dependencies and types depending on them selve. +;; dependencies and types depending on them selves. (defun sort-types-topologicaly (unsorted) (flet ((depend-p (type1) (find-if #'(lambda (type2) @@ -562,66 +604,90 @@ (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 -(init-types-in-library #.(concatenate 'string (pkg-config:pkg-variable "glib-2.0" "libdir") "/libgobject-2.0." asdf:*dso-extension*)) +(init-types-in-library glib "libgobject-2.0")