Added :except keyword to use with :ignore-prefix in DEFINE-TYPES-BY-INTROSPECTION

[clg] / glib / gtype.lisp

diff --git a/glib/gtype.lisp b/glib/gtype.lisp
index f6d27f7..2b4a2d0 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.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")
 
 
 (in-package "GLIB")
 


@@ -121,7 +121,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 +137,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))

 
 
 
 
 
 


@@ -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)
   (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 +244,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 +287,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 +318,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))

+
+
+