X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/d4b21b082be225e0c0edaa822bd8b1e267e2f87a..d168bafdb3b5b6614755bb431778e895122f2be5:/glib/gtype.lisp diff --git a/glib/gtype.lisp b/glib/gtype.lisp index b5c434b..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.10 2001-05-11 16:04:33 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 @@ (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 @@ (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 @@ (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 @@ -93,8 +97,15 @@ (and error (error "Type not registered: ~A" type))))) (pcl::class (find-type-number (class-name type) error)))) -(defun type-from-number (type-number) - (gethash type-number *number-to-type-hash*)) +(defun type-from-number (type-number &optional error) + (multiple-value-bind (type found) + (gethash type-number *number-to-type-hash*) + (when (and error (not found)) + (let ((name (find-type-name type-number))) + (if name + (error "Type number not registered: ~A (~A)" type-number name) + (error "Invalid type number: ~A" type-number)))) + type)) (defun type-from-name (name) (etypecase name @@ -112,21 +123,30 @@ (funcall (mkbinding fname 'type-number))) (mklist init))) -(defmacro init-types-in-library (pathname) +(defun %init-types-in-library (pathname prefix ignore) (let ((process (ext:run-program - "nm" (list (namestring (truename pathname))) + "nm" (list "-D" (namestring (truename pathname))) :output :stream :wait nil)) (fnames ())) (labels ((read-symbols () (let ((line (read-line (ext:process-output process) nil))) (when line - (when (search "_get_type" line) - (push (subseq line 11) fnames)) + (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))) (read-symbols))))) (read-symbols) (ext:process-close process) `(init-type ',fnames)))) +(defmacro init-types-in-library (filename &key (prefix "") ignore) + (%init-types-in-library filename prefix ignore)) + + ;;;; Superclass for wrapping types in the glib type system @@ -137,54 +157,39 @@ (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))))) + (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)))) - (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)) @@ -201,34 +206,26 @@ (register-type 'unsigned-long "gulong") (register-type 'single-float "gfloat") (register-type 'double-float "gdouble") -(register-type 'string "GString") +(register-type 'string "gchararray") ;;;; -(defvar *derivable-type-info* ()) +(defvar *derivable-type-info* (make-hash-table)) -(defun register-derivable-type (type id &key query expand) +(defun register-derivable-type (type id expander) (register-type type id) - (let* ((type-number (register-type type id)) - (info (assoc type-number *derivable-type-info*))) - (if info - (setf (cdr info) (list query expand)) - (push - (list type-number query expand) - *derivable-type-info*)))) - -(defun type-dependencies (type) - (let ((query (second (assoc (car (last (type-hierarchy type))) - *derivable-type-info*)))) - (when query - (funcall query (find-type-number type t))))) - -(defun expand-type-definition (type) - (let ((expander (third (assoc (car (last (type-hierarchy type))) - *derivable-type-info*)))) - (funcall expander (find-type-number type t)))) + (let ((type-number (register-type type id))) + (setf (gethash type-number *derivable-type-info*) expander))) + +(defun find-type-info (type) + (dolist (super (cdr (type-hierarchy type))) + (let ((info (gethash super *derivable-type-info*))) + (return-if info)))) +(defun expand-type-definition (type options) + (let ((expander (find-type-info type))) + (funcall expander (find-type-number type t) options))) (defbinding type-parent (type) type-number ((find-type-number type t) type-number)) @@ -236,6 +233,19 @@ (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) @@ -253,7 +263,7 @@ (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 @@ -266,26 +276,30 @@ (defun find-types (prefix) (let ((type-list nil)) - (dolist (type-info *derivable-type-info*) - (map-subtypes - #'(lambda (type-number) - (push type-number type-list)) - (first type-info) prefix)) + (maphash + #'(lambda (type-number expander) + (declare (ignore expander)) + (map-subtypes + #'(lambda (type-number) + (pushnew type-number type-list)) + type-number prefix)) + *derivable-type-info*) type-list)) (defun %sort-types-topologicaly (unsorted) (let ((sorted ())) (loop while unsorted do (dolist (type unsorted) - (let ((dependencies (type-dependencies type))) + (let ((dependencies + (append (rest (type-hierarchy type)) (type-interfaces type)))) (cond ((null dependencies) (push type sorted) (setq unsorted (delete type unsorted))) (t (unless (dolist (dep dependencies) - (when (find type (type-dependencies dep)) - (error "Cyclic type dependencies not yet supported")) + (when (find type (rest (type-hierarchy dep))) + (error "Cyclic type dependencie")) (return-if (find dep unsorted))) (push type sorted) (setq unsorted (delete type unsorted)))))))) @@ -293,27 +307,42 @@ (defun expand-type-definitions (prefix &optional args) - (flet ((type-options (type-number) + (flet ((type-options (type-number) (let ((name (find-type-name type-number))) - (cdr (assoc name argss :test #'string=))))) + (cdr (assoc name args :test #'string=))))) - (let ((type-list - (delete-if - #'(lambda (type-number) - (getf (type-options type-number) :ignore nil)) - (find-types prefix)))) + (let ((type-list + (delete-if + #'(lambda (type-number) + (let ((name (find-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-type-name type-number))) - (register-type - (getf (type-options type-number) :type (default-type-name name)) - type-number))) - - `(progn - ,@(mapcar - #'expand-type-definition - (%sort-types-topologicaly type-list)))))) - + (dolist (type-number type-list) + (let ((name (find-type-name type-number))) + (register-type + (getf (type-options type-number) :type (default-type-name name)) + type-number))) + + `(progn + ,@(mapcar + #'(lambda (type) + (expand-type-definition type (type-options type))) + (%sort-types-topologicaly type-list)))))) + (defmacro define-types-by-introspection (prefix &rest args) - `(eval-when (:compile-toplevel :load-toplevel :execute) - ,(expand-type-definitions prefix args))) \ No newline at end of file + (expand-type-definitions prefix args)) + + +