X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/daa10b6dab91646d3fab1db9593b69b9cde6cf04..9cbf385857b0d6f4d41d374e0b1673293eee59a0:/glib/gtype.lisp diff --git a/glib/gtype.lisp b/glib/gtype.lisp index c82334b..4762a7a 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.56 2006-08-30 11:11:03 espen Exp $ +;; $Id: gtype.lisp,v 1.65 2007-10-17 14:33:50 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) @@ -201,45 +204,68 @@ (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 %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" (namestring (truename pathname))) - :output :stream :wait nil))) + (let ((outname (tmpname "types"))) (unwind-protect - (loop - as symbol = (let* ((line (read-line - #+(or cmu sbcl) - (process-output process) - #+clisp process - nil)) - (pos (position #\Space line :from-end t))) - (when (and line #+darwin(char= (char line (1- pos)) #\T)) - (subseq line (1+ pos)))) - while symbol - when (and - (> (length symbol) 9) - (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))))) + + +(defmacro init-types-in-library (system library &key prefix ignore) + (let* ((filename (asdf:component-pathname (asdf:find-component (asdf:find-system system) library))) + (names (%find-types-in-library filename prefix ignore))) `(progn ,@(mapcar #'(lambda (name) `(progn @@ -363,7 +389,7 @@ (defmethod validate-superclass ((class ginstance-class) (super standard-class)) ;;;; Superclass for wrapping types in the glib type system (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass ginstance (proxy) + (defclass ginstance (ref-counted-object) (;(class :allocation :alien :type pointer :offset 0) ) (:metaclass proxy-class) @@ -395,12 +421,6 @@ (defmethod make-proxy-instance :around ((class ginstance-class) location (error "Object at ~A has an unkown type number: ~A" location (%type-number-of-ginstance location))))) -(define-type-method from-alien-form ((type ginstance) form &key (ref :copy)) - (call-next-method type form :ref ref)) - -(define-type-method from-alien-function ((type ginstance) &key (ref :copy)) - (call-next-method type :ref ref)) - ;;;; Registering fundamental types @@ -417,8 +437,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 @@ -511,7 +531,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) @@ -625,4 +645,4 @@ (defexport define-types-by-introspection (prefix &rest 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")