Added handle box demo and some other changes

[clg] / glib / glib.lisp

diff --git a/glib/glib.lisp b/glib/glib.lisp
index 6ee148807528262195a74cd7ab1a63fc4be98ad1..afc7a8341a1f983bc558be16ee9712d1179aa667 100644 (file)
--- a/glib/glib.lisp
+++ b/glib/glib.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: glib.lisp,v 1.20 2004/11/21 17:37:24 espen Exp $
+;; $Id: glib.lisp,v 1.23 2005/01/03 16:38:57 espen Exp $
 
 
 (in-package "GLIB")
@@ -64,6 +64,16 @@ (defun find-user-data (id)
   (multiple-value-bind (user-data p) (gethash id *user-data*)
     (values (car user-data) p)))
 
+(defun update-user-data (id object)
+  (check-type id fixnum)
+  (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
+    (cond
+     ((not exists-p) (error "User data id ~A does not exist" id))
+     (t 
+      (when (cdr user-data)
+       (funcall (cdr user-data) (car user-data)))
+      (setf (car user-data) object)))))
+
 (defun destroy-user-data (id)
   (check-type id fixnum)
   (let ((user-data (gethash id *user-data*)))
@@ -225,11 +235,35 @@ (defmethod cleanup-form (glist (type (eql 'glist)) &rest args)
     `(destroy-glist ,glist ',element-type)))
 
 (defmethod cleanup-function ((type (eql 'glist)) &rest args)
-  (declare (ignore type args))
+  (declare (ignore type))
   (destructuring-bind (element-type) args
     #'(lambda (glist)
        (destroy-glist glist element-type))))
 
+(defmethod writer-function ((type (eql 'glist)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type) args
+    #'(lambda (list location &optional (offset 0))
+       (setf 
+        (sap-ref-sap location offset)
+        (make-glist element-type list)))))
+
+(defmethod reader-function ((type (eql 'glist)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type) args
+    #'(lambda (location &optional (offset 0))
+       (unless (null-pointer-p (sap-ref-sap location offset))
+         (map-glist 'list #'identity (sap-ref-sap location offset) element-type)))))
+
+(defmethod destroy-function ((type (eql 'glist)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type) args
+    #'(lambda (location &optional (offset 0))
+       (unless (null-pointer-p (sap-ref-sap location offset))
+         (destroy-glist (sap-ref-sap location offset) element-type)
+         (setf (sap-ref-sap location offset) (make-pointer 0))))))
+
+
 
 ;;;; Single linked list (GSList)
 
@@ -305,16 +339,38 @@ (defmethod from-alien-function ((type (eql 'gslist)) &rest args)
        (map-glist 'list #'identity gslist element-type))))
 
 (defmethod cleanup-form (gslist (type (eql 'gslist)) &rest args)
-  (declare (ignore type args))
+  (declare (ignore type))
   (destructuring-bind (element-type) args
     `(destroy-gslist ,gslist ',element-type)))
 
 (defmethod cleanup-function ((type (eql 'gslist)) &rest args)
-  (declare (ignore type args))
+  (declare (ignore type))
   (destructuring-bind (element-type) args
     #'(lambda (gslist)
        (destroy-gslist gslist element-type))))
 
+(defmethod writer-function ((type (eql 'gslist)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type) args
+    #'(lambda (list location &optional (offset 0))
+       (setf 
+        (sap-ref-sap location offset)
+        (make-gslist element-type list)))))
+
+(defmethod reader-function ((type (eql 'gslist)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type) args
+    #'(lambda (location &optional (offset 0))
+       (unless (null-pointer-p (sap-ref-sap location offset))
+         (map-glist 'list #'identity (sap-ref-sap location offset) element-type)))))
+
+(defmethod destroy-function ((type (eql 'gslist)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type) args
+    #'(lambda (location &optional (offset 0))
+       (unless (null-pointer-p (sap-ref-sap location offset))
+         (destroy-gslist (sap-ref-sap location offset) element-type)
+         (setf (sap-ref-sap location offset) (make-pointer 0))))))
 
 
 ;;; Vector
@@ -404,7 +460,7 @@ (defmethod from-alien-form (c-vector (type (eql 'vector)) &rest args)
        (error "Can't use vector of variable size as return type")
       `(let ((c-vector ,c-vector))
        (prog1
-           (map-c-vector 'vector #'identity ',element-type ,length c-vector)
+           (map-c-vector 'vector #'identity c-vector ',element-type ,length)
          (destroy-c-vector c-vector ',element-type ,length))))))
 
 (defmethod copy-from-alien-form (c-vector (type (eql 'vector)) &rest args)
@@ -412,7 +468,7 @@ (defmethod copy-from-alien-form (c-vector (type (eql 'vector)) &rest args)
   (destructuring-bind (element-type &optional (length '*)) args
     (if (eq length '*)
        (error "Can't use vector of variable size as return type")
-      `(map-c-vector 'vector #'identity ',element-type ',length ,c-vector))))
+      `(map-c-vector 'vector #'identity ,c-vector ',element-type ',length))))
 
 (defmethod cleanup-form (location (type (eql 'vector)) &rest args)
   (declare (ignore type))
@@ -429,3 +485,32 @@ (defmethod cleanup-form (location (type (eql 'vector)) &rest args)
       (deallocate-memory ,(if (eq length '*) 
                              `(sap+ location  ,(- +size-of-int+))
                            'location)))))
+
+(defmethod writer-function ((type (eql 'vector)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type &optional (length '*)) args
+    #'(lambda (vector location &optional (offset 0))
+       (setf 
+        (sap-ref-sap location offset)
+        (make-c-vector element-type length vector)))))
+
+(defmethod reader-function ((type (eql 'vector)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type &optional (length '*)) args
+    (if (eq length '*)
+       (error "Can't create reader function for vector of variable size")
+      #'(lambda (location &optional (offset 0))
+         (unless (null-pointer-p (sap-ref-sap location offset))
+           (map-c-vector 'vector #'identity (sap-ref-sap location offset) 
+            element-type length))))))
+
+(defmethod destroy-function ((type (eql 'vector)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type &optional (length '*)) args
+    (if (eq length '*)
+       (error "Can't create destroy function for vector of variable size")
+      #'(lambda (location &optional (offset 0))
+         (unless (null-pointer-p (sap-ref-sap location offset))
+           (destroy-c-vector 
+            (sap-ref-sap location offset) element-type length)
+           (setf (sap-ref-sap location offset) (make-pointer 0)))))))