Signal handling code added

[clg] / glib / gtype.lisp

diff --git a/glib/gtype.lisp b/glib/gtype.lisp
index b5c434b..e6850b6 100644 (file)
--- a/glib/gtype.lisp
+++ b/glib/gtype.lisp
@@ -15,33 +15,71 @@
 ;; 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.22 2004-12-28 20:30:06 espen Exp $

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

-;;;; 
+;; Initialize the glib type system
+(defbinding type-init () nil)
+(type-init)

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

+(deftype gtype () 'symbol)
+
+(defmethod alien-type ((type (eql 'gtype)) &rest args)
+  (declare (ignore type args))
+  (alien-type 'type-number))
+
+(defmethod size-of ((type (eql 'gtype)) &rest args)
+  (declare (ignore type args))
+  (size-of 'type-number))
+
+(defmethod to-alien-form (gtype (type (eql 'gtype)) &rest args)
+  (declare (ignore type args))
+  `(find-type-number ,gtype t)) 
+
+(defmethod to-alien-function ((type (eql 'gtype)) &rest args)
+  (declare (ignore type args))
+  #'(lambda (gtype)
+      (find-type-number gtype t)))
+
+(defmethod from-alien-form (type-number (type (eql 'gtype)) &rest args)
+  (declare (ignore type args))
+  `(type-from-number ,type-number t)) 
+
+(defmethod from-alien-function ((type (eql 'gtype)) &rest args)
+  (declare (ignore type args))
+  #'(lambda (type-number)
+      (type-from-number type-number t)))
+
+(defmethod writer-function ((type (eql 'gtype)) &rest args)
+  (declare (ignore type))
+  (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))
+  (let ((reader (reader-function 'type-number)))
+    #'(lambda (location &optional (offset 0))
+       (type-from-number (funcall reader location offset) t))))
+
+

 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defclass type-query (struct)
     ((type-number :allocation :alien :type type-number)
      (name :allocation :alien :type string)
      (class-size :allocation :alien :type unsigned-int)
      (instance-size :allocation :alien :type unsigned-int))
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defclass type-query (struct)
     ((type-number :allocation :alien :type type-number)
      (name :allocation :alien :type string)
      (class-size :allocation :alien :type unsigned-int)
      (instance-size :allocation :alien :type unsigned-int))

-    (:metaclass proxy-class)))
-
+    (:metaclass struct-class)))

 
 

-(defbinding %type-query () nil
-  (type type-number)
-  (query type-query))

 
 

-(defun type-query (type)
-  (let ((query (make-instance 'type-query)))
-    (%type-query (find-type-number type t) query)
-    query))
+(defbinding type-query (type) nil
+  ((find-type-number type t) type-number)
+  ((make-instance 'type-query) type-query :return))

 
 (defun type-instance-size (type)
   (slot-value (type-query type) 'instance-size))
 
 (defun type-instance-size (type)
   (slot-value (type-query type) 'instance-size))


@@ -68,9 +106,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


@@ -83,7 +123,7 @@
      (let ((type-number (%type-from-name type)))
        (cond
        ((and (zerop type-number) error)
      (let ((type-number (%type-from-name type)))
        (cond
        ((and (zerop type-number) error)

-        (error "Invalid alien type name: ~A" type))
+        (error "Invalid gtype name: ~A" type))

        ((zerop type-number) nil)
        (t type-number))))
     (symbol
        ((zerop type-number) nil)
        (t type-number))))
     (symbol


@@ -93,14 +133,21 @@
        (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
     (string (type-from-number (find-type-number name t)))))
 
 
 (defun type-from-name (name)
   (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)
   ((find-type-number type t) type-number))
 
 (defun type-number-of (object)


@@ -112,21 +159,30 @@
        (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 prefix 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
+                           (> (length symbol) (length prefix))
+                           (string= prefix symbol :end2 (length prefix))
+                           (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 (prefix "") ignore)
+  (%init-types-in-library filename prefix ignore))
+
+

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


@@ -137,54 +193,52 @@
 
 (defun %type-of-ginstance (location)
   (let ((class (sap-ref-sap location 0)))
 
 (defun %type-of-ginstance (location)
   (let ((class (sap-ref-sap location 0)))

-    (type-from-number (sap-ref-unsigned class 0))))
+    (type-from-number (sap-ref-32 class 0))))
+
+(defmethod ensure-proxy-instance ((class ginstance-class) location)
+  (declare (ignore class))
+  (let ((class (find-class (%type-of-ginstance location))))
+    (if class
+       (make-instance class :location (reference-foreign class location))
+      ;; TODO: (make-instance 'ginstance ...)
+      location)))

 
 

-(deftype-method translate-from-alien
-    ginstance (type-spec location &optional weak-ref)
-  (declare (ignore type-spec))
-  `(let ((location ,location))
-     (unless (null-pointer-p location)
-       (ensure-proxy-instance
-       (%type-of-ginstance location) location ,weak-ref))))
+(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
 
 (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
 
 
 (defmethod shared-initialize ((class ginstance-class) names

-                             &rest initargs &key name alien-name
-                             size ref unref)
-  (declare (ignore initargs names))
+                             &rest initargs &key name alien-name)
+  (declare (ignore 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)
     (register-type class-name type-number)

-    (let ((size (or size (type-instance-size type-number))))
-      (call-next-method)))
-
-  (when ref
-    (let ((ref (mkbinding (first ref) 'pointer 'pointer)))
-      (setf
-       (slot-value class 'copy)
-       #'(lambda (type location)
-          (declare (ignore type))
-          (funcall ref location)))))     
-  (when unref
-    (let ((unref (mkbinding (first unref) 'nil 'pointer)))
-      (setf
-       (slot-value class 'free)
-       #'(lambda (type location)
-          (declare (ignore type))
-          (funcall unref location))))))
-
-
-(defmethod validate-superclass
-    ((class ginstance-class) (super pcl::standard-class))
+    (if (getf initargs :size)
+       (call-next-method)
+      (let ((size (type-instance-size type-number)))
+       (apply #'call-next-method class names :size (list size) initargs)))))
+
+
+(defmethod validate-superclass ((class ginstance-class) (super standard-class))

   (subtypep (class-name super) 'ginstance))
 
 
   (subtypep (class-name super) 'ginstance))
 
 


@@ -201,34 +255,27 @@
 (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 'pathname "gchararray")
+(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))


@@ -236,6 +283,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-vector '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)


@@ -253,7 +313,7 @@
   (let ((type-number (find-type-number type t)))
     (multiple-value-bind (array length) (%type-children type-number)
       (unwind-protect
   (let ((type-number (find-type-number type t)))
     (multiple-value-bind (array length) (%type-children type-number)
       (unwind-protect

-         (map-c-array
+         (map-c-vector

           'nil
           #'(lambda (type-number)
               (when (or
           'nil
           #'(lambda (type-number)
               (when (or


@@ -266,26 +326,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)
-          (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
+              (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))))))))


@@ -293,27 +357,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)))
           (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)
+                       (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)
 (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))
+
+
+