X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/e74cfcab32b6d3328acdad68b4acc087c6375fb6..f4ba8dcb96baefeab615d39c901769b7136e32aa:/glib/gtype.lisp diff --git a/glib/gtype.lisp b/glib/gtype.lisp index c674a21..2a14c73 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.20 2004-11-13 16:37:09 espen Exp $ +;; $Id: gtype.lisp,v 1.25 2005-02-03 23:09:04 espen Exp $ (in-package "GLIB") @@ -48,24 +48,24 @@ (defmethod from-alien-form (type-number (type (eql 'gtype)) &rest args) (declare (ignore type args)) - `(type-from-number ,type-number t)) + `(type-from-number ,type-number)) (defmethod from-alien-function ((type (eql 'gtype)) &rest args) (declare (ignore type args)) #'(lambda (type-number) - (type-from-number type-number t))) + (type-from-number type-number))) (defmethod writer-function ((type (eql 'gtype)) &rest args) - (declare (ignore type)) + (declare (ignore type args)) (let ((writer (writer-function 'type-number))) #'(lambda (gtype location &optional (offset 0)) (funcall writer (find-type-number gtype t) location offset)))) (defmethod reader-function ((type (eql 'gtype)) &rest args) - (declare (ignore type)) + (declare (ignore type args)) (let ((reader (reader-function 'type-number))) #'(lambda (location &optional (offset 0)) - (type-from-number (funcall reader location offset) t)))) + (type-from-number (funcall reader location offset))))) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -131,7 +131,7 @@ (or type-number (and error (error "Type not registered: ~A" type))))) - (pcl::class (find-type-number (class-name type) error)))) + (class (find-type-number (class-name type) error)))) (defun type-from-number (type-number &optional error) (multiple-value-bind (type found) @@ -147,7 +147,7 @@ (etypecase name (string (type-from-number (find-type-number name t))))) -(defbinding (find-type-name "g_type_name") (type) string +(defbinding (find-type-name "g_type_name") (type) (copy-of string) ((find-type-number type t) type-number)) (defun type-number-of (object) @@ -160,12 +160,12 @@ (mklist init))) (defun %init-types-in-library (pathname prefix ignore) - (let ((process (ext:run-program - "nm" (list "-D" (namestring (truename pathname))) + (let ((process (run-program + "/usr/bin/nm" (list "--defined-only" "-D" (namestring (truename pathname))) :output :stream :wait nil)) (fnames ())) (labels ((read-symbols () - (let ((line (read-line (ext:process-output process) nil))) + (let ((line (read-line (process-output process) nil))) (when line (let ((symbol (subseq line 11))) (when (and @@ -176,7 +176,7 @@ (push symbol fnames))) (read-symbols))))) (read-symbols) - (ext:process-close process) + (process-close process) `(init-type ',fnames)))) (defmacro init-types-in-library (filename &key (prefix "") ignore) @@ -203,6 +203,19 @@ ;; TODO: (make-instance 'ginstance ...) location))) +(defmethod copy-from-alien-form (location (class ginstance-class) &rest args) + (declare (ignore location class args)) + (error "Doing copy-from-alien on a ref. counted class is most certainly an error, but if it really is what you want you should use REFERENCE-FOREIGN on the returned instance instead.")) + +(defmethod copy-from-alien-function ((class ginstance-class) &rest args) + (declare (ignore class args)) + (error "Doing copy-from-alien on a ref. counted class is most certainly an error, but if it really is what you want you should use REFERENCE-FOREIGN on the returned instance instead.")) + +(defmethod reader-function ((class ginstance-class) &rest args) + (declare (ignore args)) + #'(lambda (location &optional (offset 0)) + (ensure-proxy-instance class (sap-ref-sap location offset)))) + ;;;; Metaclass for subclasses of ginstance @@ -231,6 +244,7 @@ ;;;; Registering fundamental types +(register-type 'nil "void") (register-type 'pointer "gpointer") (register-type 'char "gchar") (register-type 'unsigned-char "guchar") @@ -242,26 +256,29 @@ (register-type 'unsigned-long "gulong") (register-type 'single-float "gfloat") (register-type 'double-float "gdouble") +(register-type 'pathname "gchararray") (register-type 'string "gchararray") -;;;; +;;;; Introspection of type information (defvar *derivable-type-info* (make-hash-table)) -(defun register-derivable-type (type id expander) +(defun register-derivable-type (type id expander &optional dependencies) (register-type type id) (let ((type-number (register-type type id))) - (setf (gethash type-number *derivable-type-info*) expander))) + (setf + (gethash type-number *derivable-type-info*) + (list expander dependencies)))) (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))) +(defun expand-type-definition (type forward-p options) + (let ((expander (first (find-type-info type)))) + (funcall expander (find-type-number type t) forward-p options))) (defbinding type-parent (type) type-number ((find-type-number type t) type-number)) @@ -322,24 +339,37 @@ *derivable-type-info*) type-list)) -(defun %sort-types-topologicaly (unsorted) - (let ((sorted ())) - (loop while unsorted do - (dolist (type unsorted) - (let ((dependencies - (append (rest (type-hierarchy type)) (type-interfaces type)))) +(defun find-type-dependencies (type) + (let ((list-dependencies (second (find-type-info type)))) + (when list-dependencies + (funcall list-dependencies (find-type-number type t))))) + +(defun %sort-types-topologicaly (types) + (let ((unsorted (mapcar + #'(lambda (type) + (cons type (remove-if #'(lambda (dep) + (not (find dep types))) + (find-type-dependencies type)))) + types)) + (forward-define ()) + (sorted ())) + + (loop + as tmp = unsorted then (or (rest tmp) unsorted) + while tmp + do (destructuring-bind (type . dependencies) (first tmp) (cond - ((null dependencies) + ((every #'(lambda (dep) + (or (find dep forward-define) (find dep sorted))) + dependencies) (push type sorted) - (setq unsorted (delete type unsorted))) - (t - (unless (dolist (dep dependencies) - (when (find type (rest (type-hierarchy dep))) - (error "Cyclic type dependencie")) - (return-if (find dep unsorted))) - (push type sorted) - (setq unsorted (delete type unsorted)))))))) - (nreverse sorted))) + (setq unsorted (delete type unsorted :key #'first))) + ((some #'(lambda (dep) + (find type (find-type-dependencies dep))) + dependencies) + (push type forward-define))))) + + (values (nreverse sorted) forward-define))) (defun expand-type-definitions (prefix &optional args) @@ -370,15 +400,18 @@ (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)))))) + + (multiple-value-bind (sorted-type-list forward-define) + (%sort-types-topologicaly type-list) + `(progn + ,@(mapcar + #'(lambda (type) + (expand-type-definition type t (type-options type))) + forward-define) + ,@(mapcar + #'(lambda (type) + (expand-type-definition type nil (type-options type))) + sorted-type-list)))))) (defmacro define-types-by-introspection (prefix &rest args) (expand-type-definitions prefix args)) - - -