X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/b2bea410be9b14ef1e81f8b09ad0983fbc2f57db..d168bafdb3b5b6614755bb431778e895122f2be5:/glib/gtype.lisp diff --git a/glib/gtype.lisp b/glib/gtype.lisp index 13c5c7e..70f9eeb 100644 --- a/glib/gtype.lisp +++ b/glib/gtype.lisp @@ -15,13 +15,15 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;; $Id: gtype.lisp,v 1.14 2002-01-14 01:16:08 espen Exp $ +;; $Id: gtype.lisp,v 1.19 2004-11-07 01:21:04 espen Exp $ (in-package "GLIB") (use-prefix "g") -;;;; +;; Initialize the glib type system +(defbinding type-init () nil) +(type-init) (deftype type-number () '(unsigned 32)) @@ -31,7 +33,7 @@ (defclass type-query (struct) (name :allocation :alien :type string) (class-size :allocation :alien :type unsigned-int) (instance-size :allocation :alien :type unsigned-int)) - (:metaclass proxy-class))) + (:metaclass struct-class))) (defbinding %type-query () nil @@ -68,9 +70,11 @@ (defun register-type (type id) (let ((type-number (etypecase id (integer id) - (string (find-type-number id t))))) + (string (find-type-number id t)) + (symbol (gethash id *type-to-number-hash*))))) (setf (gethash type *type-to-number-hash*) type-number) - (setf (gethash type-number *number-to-type-hash*) type) + (unless (symbolp id) + (setf (gethash type-number *number-to-type-hash*) type)) type-number)) (defbinding %type-from-name () type-number @@ -83,7 +87,7 @@ (defun find-type-number (type &optional error) (let ((type-number (%type-from-name type))) (cond ((and (zerop type-number) error) - (error "Invalid alien type name: ~A" type)) + (error "Invalid gtype name: ~A" type)) ((zerop type-number) nil) (t type-number)))) (symbol @@ -119,7 +123,7 @@ (defun init-type (init) (funcall (mkbinding fname 'type-number))) (mklist init))) -(defun %init-types-in-library (pathname ignore) +(defun %init-types-in-library (pathname prefix ignore) (let ((process (ext:run-program "nm" (list "-D" (namestring (truename pathname))) :output :stream :wait nil)) @@ -129,6 +133,8 @@ (defun %init-types-in-library (pathname ignore) (when line (let ((symbol (subseq line 11))) (when (and + (> (length symbol) (length prefix)) + (string= prefix symbol :end2 (length prefix)) (search "_get_type" symbol) (not (member symbol ignore :test #'string=))) (push symbol fnames))) @@ -137,9 +143,8 @@ (defun %init-types-in-library (pathname ignore) (ext:process-close process) `(init-type ',fnames)))) -(defmacro init-types-in-library (filename &key ignore) - (%init-types-in-library - (format nil "~A/~A" *gtk-library-path* filename) ignore)) +(defmacro init-types-in-library (filename &key (prefix "") ignore) + (%init-types-in-library filename prefix ignore)) @@ -152,55 +157,39 @@ (defclass ginstance (proxy) (defun %type-of-ginstance (location) (let ((class (sap-ref-sap location 0))) - (type-from-number (sap-ref-unsigned class 0)))) - -(deftype-method translate-from-alien - ginstance (type-spec location &optional weak-ref) - (declare (ignore type-spec)) - `(let ((location ,location)) - (unless (null-pointer-p location) - (ensure-proxy-instance - (%type-of-ginstance location) location ,weak-ref)))) + (type-from-number (sap-ref-32 class 0)))) +(defmethod ensure-proxy-instance ((class ginstance-class) location) + (declare (ignore class)) + (let ((class (find-class (%type-of-ginstance location)))) + (if class + (make-instance class :location (reference-foreign class location)) + ;; TODO: (make-instance 'ginstance ...) + location))) ;;;; Metaclass for subclasses of ginstance (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass ginstance-class (proxy-class))) + (defclass ginstance-class (proxy-class) + ())) (defmethod shared-initialize ((class ginstance-class) names - &rest initargs &key name alien-name - size ref unref) - (declare (ignore initargs names)) + &rest initargs &key name alien-name) + (declare (ignore names)) (let* ((class-name (or name (class-name class))) (type-number (find-type-number (or (first alien-name) (default-alien-type-name class-name)) t))) (register-type class-name type-number) - (let ((size (or size (type-instance-size type-number)))) - (declare (special size)) - (call-next-method))) - - (when ref - (let ((ref (mkbinding (first ref) 'pointer 'pointer))) - (setf - (slot-value class 'copy) - #'(lambda (type location) - (declare (ignore type)) - (funcall ref location))))) - (when unref - (let ((unref (mkbinding (first unref) 'nil 'pointer))) - (setf - (slot-value class 'free) - #'(lambda (type location) - (declare (ignore type)) - (funcall unref location)))))) - - -(defmethod validate-superclass - ((class ginstance-class) (super pcl::standard-class)) + (if (getf initargs :size) + (call-next-method) + (let ((size (type-instance-size type-number))) + (apply #'call-next-method class names :size (list size) initargs))))) + + +(defmethod validate-superclass ((class ginstance-class) (super standard-class)) (subtypep (class-name super) 'ginstance)) @@ -244,6 +233,19 @@ (defbinding type-parent (type) type-number (defun supertype (type) (type-from-number (type-parent type))) +(defbinding %type-interfaces (type) pointer + ((find-type-number type t) type-number) + (n-interfaces unsigned-int :out)) + +(defun type-interfaces (type) + (multiple-value-bind (array length) (%type-interfaces type) + (unwind-protect + (map-c-vector 'list #'identity array 'type-number length) + (deallocate-memory array)))) + +(defun implements (type) + (mapcar #'type-from-number (type-interfaces type))) + (defun type-hierarchy (type) (let ((type-number (find-type-number type t))) (unless (= type-number 0) @@ -261,7 +263,7 @@ (defun map-subtypes (function type &optional prefix) (let ((type-number (find-type-number type t))) (multiple-value-bind (array length) (%type-children type-number) (unwind-protect - (map-c-array + (map-c-vector 'nil #'(lambda (type-number) (when (or @@ -288,7 +290,8 @@ (defun %sort-types-topologicaly (unsorted) (let ((sorted ())) (loop while unsorted do (dolist (type unsorted) - (let ((dependencies (rest (type-hierarchy type)))) + (let ((dependencies + (append (rest (type-hierarchy type)) (type-interfaces type)))) (cond ((null dependencies) (push type sorted) @@ -318,7 +321,11 @@ (defun expand-type-definitions (prefix &optional args) #'(lambda (options) (and (string-prefix-p (first options) name) - (getf (cdr options) :ignore-prefix))) + (getf (cdr options) :ignore-prefix) + (not (some + #'(lambda (exception) + (string= name exception)) + (getf (cdr options) :except))))) args)))) (find-types prefix))))