Renamed to export.lisp

[clg] / glib / gtype.lisp

diff --git a/glib/gtype.lisp b/glib/gtype.lisp
index f6d27f7..02f9677 100644 (file)
--- a/glib/gtype.lisp
+++ b/glib/gtype.lisp
@@ -15,12 +15,14 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 ;; 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.17 2004-10-27 14:59:00 espen Exp $

 
 (in-package "GLIB")
 
 (use-prefix "g")
 
 
 (in-package "GLIB")
 
 (use-prefix "g")
 

+;(load-shared-library "libgobject-2.0" :init "g_type_init")
+

 ;;;; 
 
 (deftype type-number () '(unsigned 32))
 ;;;; 
 
 (deftype type-number () '(unsigned 32))


@@ -68,9 +70,11 @@
   (let ((type-number
         (etypecase id
           (integer 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 *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
     type-number))
 
 (defbinding %type-from-name () type-number


@@ -121,7 +125,7 @@
 
 (defun %init-types-in-library (pathname ignore)
   (let ((process (ext:run-program
 
 (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 ()
                  :output :stream :wait nil))
        (fnames ()))
     (labels ((read-symbols ()


@@ -137,8 +141,9 @@
       (ext:process-close process)
       `(init-type ',fnames))))
 
       (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))

 
 
 
 
 
 


@@ -166,21 +171,23 @@
 ;;;; Metaclass for subclasses of ginstance
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 ;;;; 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
 
 
 (defmethod shared-initialize ((class ginstance-class) names
                              &rest initargs &key name alien-name

-                             size ref unref)
+                             ref unref)

   (declare (ignore initargs 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)
   (declare (ignore initargs 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)))
+    (if (getf initargs :size)
+       (call-next-method)
+      (let ((size (type-instance-size type-number)))
+       (apply #'call-next-method class names :size (list size) initargs))))

 
   (when ref
     (let ((ref (mkbinding (first ref) 'pointer 'pointer)))
 
   (when ref
     (let ((ref (mkbinding (first ref) 'pointer 'pointer)))


@@ -188,7 +195,7 @@
        (slot-value class 'copy)
        #'(lambda (type location)
           (declare (ignore type))
        (slot-value class 'copy)
        #'(lambda (type location)
           (declare (ignore type))

-          (funcall ref location)))))     
+          (funcall ref location)))))

   (when unref
     (let ((unref (mkbinding (first unref) 'nil 'pointer)))
       (setf
   (when unref
     (let ((unref (mkbinding (first unref) 'nil 'pointer)))
       (setf


@@ -221,31 +228,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)
   (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)))
 
 (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))))
 
       (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))
 
 (defbinding type-parent (type) type-number
   ((find-type-number type t) type-number))


@@ -253,6 +250,19 @@
 (defun supertype (type)
   (type-from-number (type-parent type)))
 
 (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)
 (defun type-hierarchy (type)
   (let ((type-number (find-type-number type t)))
     (unless (= type-number 0)


@@ -283,26 +293,30 @@
 
 (defun find-types (prefix)
   (let ((type-list nil))
 
 (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)
     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)
          (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))))))))
                      (return-if (find dep unsorted)))
              (push type sorted)
              (setq unsorted (delete type unsorted))))))))


@@ -310,34 +324,42 @@
 
 
 (defun expand-type-definitions (prefix &optional args)
 
 
 (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 ((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))
 (defmacro define-types-by-introspection (prefix &rest args)
   (expand-type-definitions prefix args))

+
+
+