X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/4de90d1003ebaa951a5b1473b5304e563be7c0c0..80a09c29e3e604a25dd0a32282bc6b2c73fbaa4d:/glib/gtype.lisp diff --git a/glib/gtype.lisp b/glib/gtype.lisp index f6d27f7..2b4a2d0 100644 --- a/glib/gtype.lisp +++ b/glib/gtype.lisp @@ -15,7 +15,7 @@ ;; 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.11 2001-05-29 15:49:23 espen Exp $ +;; $Id: gtype.lisp,v 1.16 2002-03-24 12:56:03 espen Exp $ (in-package "GLIB") @@ -121,7 +121,7 @@ (defun %init-types-in-library (pathname 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 () @@ -137,8 +137,9 @@ (ext:process-close process) `(init-type ',fnames)))) -(defmacro init-types-in-library (pathname &key ignore) - (%init-types-in-library pathname ignore)) +(defmacro init-types-in-library (filename &key ignore) + (%init-types-in-library + (format nil "~A/~A" *gtk-library-path* filename) ignore)) @@ -221,31 +222,21 @@ ;;;; -(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*)))) + (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 (assoc super *derivable-type-info*))) + (let ((info (gethash super *derivable-type-info*))) (return-if info)))) -(defun type-dependencies (type) - (let ((query (second (find-type-info type)))) - (when query - (funcall query (find-type-number type t))))) - -(defun expand-type-definition (type) - (let ((expander (third (find-type-info type)))) - (funcall expander (find-type-number type t)))) +(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)) @@ -253,6 +244,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-array '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) @@ -283,26 +287,30 @@ (defun find-types (prefix) (let ((type-list nil)) - (dolist (type-info *derivable-type-info*) - (map-subtypes - #'(lambda (type-number) - (pushnew 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)))))))) @@ -310,34 +318,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 args :test #'string=))))) - (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))) - args)))) - (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) (expand-type-definitions prefix args)) + + +