INIT-TYPES-IN-LIBRARY should now search for files in the default gtk libdir

[clg] / glib / gtype.lisp

diff --git a/glib/gtype.lisp b/glib/gtype.lisp
index b5c434b3032c5840f45684299dca18e31ace7458..6cab228055ca2352c8914ce9b6576e5cef398cbf 100644 (file)
--- 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
 
 ;; 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.13 2001-11-12 22:24:29 espen Exp $

 
 (in-package "GLIB")
 
 
 (in-package "GLIB")
 


@@ -93,8 +93,15 @@ (defun find-type-number (type &optional error)
        (and error (error "Type not registered: ~A" type)))))
     (pcl::class (find-type-number (class-name type) error))))
  
        (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
 
 (defun type-from-name (name)
   (etypecase name


@@ -112,21 +119,29 @@ (defun init-type (init)
        (funcall (mkbinding fname 'type-number)))
    (mklist init)))
 
        (funcall (mkbinding fname 'type-number)))
    (mklist init)))
 

-(defmacro init-types-in-library (pathname)
+(defun %init-types-in-library (pathname ignore)

   (let ((process (ext:run-program
   (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
                  :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
+                           (search "_get_type" symbol)
+                           (not (member symbol ignore :test #'string=)))
+                      (push symbol fnames)))

                   (read-symbols)))))
       (read-symbols)
       (ext:process-close process)
       `(init-type ',fnames))))
 
                   (read-symbols)))))
       (read-symbols)
       (ext:process-close process)
       `(init-type ',fnames))))
 

+(defmacro init-types-in-library (filename &key ignore)
+  (%init-types-in-library
+   (format nil "~A/~A" user::gtk-library-path filename) ignore))
+
+

 
 ;;;; Superclass for wrapping types in the glib type system
 
 
 ;;;; Superclass for wrapping types in the glib type system
 


@@ -162,9 +177,10 @@ (defmethod shared-initialize ((class ginstance-class) names
   (let* ((class-name (or name (class-name class)))
         (type-number
          (find-type-number
   (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))))
     (register-type class-name type-number)
     (let ((size (or size (type-instance-size type-number))))

+      (declare (special size))

       (call-next-method)))
 
   (when ref
       (call-next-method)))
 
   (when ref


@@ -201,34 +217,26 @@ (register-type 'long "glong")
 (register-type 'unsigned-long "gulong")
 (register-type 'single-float "gfloat")
 (register-type 'double-float "gdouble")
 (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)
   (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))
 
 (defbinding type-parent (type) type-number
   ((find-type-number type t) type-number))


@@ -266,26 +274,29 @@ (defun map-subtypes (function type &optional prefix)
 
 (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)
-          (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)
     type-list))
 
 (defun %sort-types-topologicaly (unsorted)
   (let ((sorted ()))
     (loop while unsorted do
       (dolist (type unsorted)

-       (let ((dependencies (type-dependencies type)))
+       (let ((dependencies (rest (type-hierarchy 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))))))))


@@ -293,27 +304,38 @@ (defun %sort-types-topologicaly (unsorted)
 
 
 (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)))
           (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)))
+                  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)
 (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))
+
+
+