X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/8755b1a5d37f2f4b853c01f0d8b121ab9ee4093a..628fd576ba4f6e93fbdc993e536ec8252d2a62ab:/glib/glib.lisp diff --git a/glib/glib.lisp b/glib/glib.lisp index 5429846..20fbc89 100644 --- 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.17 2004-11-07 01:23:38 espen Exp $ +;; $Id: glib.lisp,v 1.24 2005-01-30 14:26:41 espen Exp $ (in-package "GLIB") @@ -46,8 +46,6 @@ (internal *user-data* *user-data-count*) -(declaim (fixnum *user-data-count*)) - (defvar *user-data* (make-hash-table)) (defvar *user-data-count* 0) @@ -64,6 +62,19 @@ (multiple-value-bind (user-data p) (gethash id *user-data*) (values (car user-data) p))) +(defun user-data-exists-p (id) + (nth-value 1 (find-user-data id))) + +(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*))) @@ -71,97 +82,42 @@ (funcall (cdr user-data) (car user-data)))) (remhash id *user-data*)) -(defmacro def-callback-marshal (name (return-type &rest args)) - (let ((names (loop - for arg in args - collect (if (atom arg) (gensym) (first arg)))) - (types (loop - for arg in args - collect (if (atom arg) arg (second arg))))) - `(defcallback ,name (,return-type ,@(mapcar #'list names types) - (callback-id unsigned-int)) - (invoke-callback callback-id ',return-type ,@names)))) - ;;;; Quarks -(internal *quark-counter* *quark-from-object* *quark-to-object*) - (deftype quark () 'unsigned) -;(defbinding %quark-get-reserved () quark) - (defbinding %quark-from-string () quark (string string)) -(defvar *quark-counter* 0) - -(defun %quark-get-reserved () - ;; The string is just a dummy - (%quark-from-string (format nil "#@£$%&-quark-~D" (incf *quark-counter*)))) - -(defvar *quark-from-object* (make-hash-table)) -(defvar *quark-to-object* (make-hash-table)) - -(defun quark-from-object (object &key (test #'eq)) - (let ((hash-code (sxhash object))) - (or - (assoc-ref object (gethash hash-code *quark-from-object*) :test test) - (let ((quark (%quark-get-reserved))) - (setf - (gethash hash-code *quark-from-object*) - (append - (gethash hash-code *quark-from-object*) - (list (cons object quark)))) - (setf (gethash quark *quark-to-object*) object) - quark)))) - -(defun quark-to-object (quark) - (gethash quark *quark-to-object*)) - -(defun remove-quark (quark) - (let* ((object (gethash quark *quark-to-object*)) - (hash-code (sxhash object))) - (remhash quark *quark-to-object*) - (unless (setf - (gethash hash-code *quark-from-object*) - (assoc-delete object (gethash hash-code *quark-from-object*))) - (remhash hash-code *quark-from-object*)))) +(defun quark-intern (object) + (etypecase object + (quark object) + (string (%quark-from-string object)) + (symbol (%quark-from-string (format nil "clg-~A:~A" + (package-name (symbol-package object)) + object))))) +(defbinding quark-to-string () (copy-of string) + (quark quark)) ;;;; Linked list (GList) -(deftype glist (type &key copy) - (declare (ignore copy)) +(deftype glist (type) `(or (null (cons ,type list)))) -(defbinding (%glist-append-unsigned "g_list_append") () pointer +(defbinding (%glist-append "g_list_append") () pointer (glist pointer) - (data unsigned)) - -(defbinding (%glist-append-signed "g_list_append") () pointer - (glist pointer) - (data signed)) - -(defbinding (%glist-append-sap "g_list_append") () pointer - (glist pointer) - (data pointer)) + (nil null)) (defun make-glist (type list) - (let ((new-element (ecase (alien-type type) - (system-area-pointer #'%glist-append-sap) - ((signed-byte c-call:short c-call:int c-call:long) - #'%glist-append-signed) - ((unsigned-byte c-call:unsigned-short - c-call:unsigned-int c-call:unsigned-long) - #'%glist-append-unsigned))) - (to-alien (to-alien-function type))) - (loop - for element in list - as glist = (funcall new-element (or glist (make-pointer 0)) - (funcall to-alien element)) - finally (return glist)))) + (loop + with writer = (writer-function type) + for element in list + as glist = (%glist-append (or glist (make-pointer 0))) + do (funcall writer element glist) + finally (return glist))) (defun glist-next (glist) (unless (null-pointer-p glist) @@ -192,6 +148,13 @@ (defbinding (glist-free "g_list_free") () nil (glist pointer)) +(defun destroy-glist (glist element-type) + (loop + with destroy = (destroy-function element-type) + as tmp = glist then (glist-next tmp) + until (null-pointer-p tmp) + do (funcall destroy tmp 0)) + (glist-free glist)) (defmethod alien-type ((type (eql 'glist)) &rest args) (declare (ignore type args)) @@ -218,7 +181,7 @@ `(let ((glist ,glist)) (unwind-protect (map-glist 'list #'identity glist ',element-type) - (glist-free glist))))) + (destroy-glist glist ',element-type))))) (defmethod from-alien-function ((type (eql 'glist)) &rest args) (declare (ignore type)) @@ -226,52 +189,81 @@ #'(lambda (glist) (unwind-protect (map-glist 'list #'identity glist element-type) - (glist-free glist))))) + (destroy-glist glist element-type))))) + +(defmethod copy-from-alien-form (glist (type (eql 'glist)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + `(map-glist 'list #'identity ,glist ',element-type))) + +(defmethod copy-from-alien-function ((type (eql 'glist)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + #'(lambda (glist) + (map-glist 'list #'identity glist element-type)))) (defmethod cleanup-form (glist (type (eql 'glist)) &rest args) - (declare (ignore type args)) - `(glist-free ,glist)) + (declare (ignore type)) + (destructuring-bind (element-type) args + `(destroy-glist ,glist ',element-type))) (defmethod cleanup-function ((type (eql 'glist)) &rest args) - (declare (ignore type args)) - #'glist-free) + (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))))) -;;;; Single linked list (GSList) +(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)))))) -(deftype gslist (type) `(or (null (cons ,type list)))) -(defbinding (%gslist-prepend-unsigned "g_slist_prepend") () pointer - (gslist pointer) - (data unsigned)) -(defbinding (%gslist-prepend-signed "g_slist_prepend") () pointer - (gslist pointer) - (data signed)) +;;;; Single linked list (GSList) + +(deftype gslist (type) `(or (null (cons ,type list)))) -(defbinding (%gslist-prepend-sap "g_slist_prepend") () pointer +(defbinding (%gslist-prepend "g_slist_prepend") () pointer (gslist pointer) - (data pointer)) + (nil null)) (defun make-gslist (type list) - (let ((new-element (ecase (alien-type type) - (system-area-pointer #'%gslist-prepend-sap) - ((signed-byte c-call:short c-call:int c-call:long) - #'%gslist-prepend-signed) - ((unsigned-byte c-call:unsigned-short - c-call:unsigned-int c-call:unsigned-long) - #'%gslist-prepend-unsigned))) - (to-alien (to-alien-function type))) - (loop - for element in (reverse list) - as gslist = (funcall new-element (or gslist (make-pointer 0)) - (funcall to-alien element)) - finally (return gslist)))) + (loop + with writer = (writer-function type) + for element in (reverse list) + as gslist = (%gslist-prepend (or gslist (make-pointer 0))) + do (funcall writer element gslist) + finally (return gslist))) (defbinding (gslist-free "g_slist_free") () nil (gslist pointer)) +(defun destroy-gslist (gslist element-type) + (loop + with destroy = (destroy-function element-type) + as tmp = gslist then (glist-next tmp) + until (null-pointer-p tmp) + do (funcall destroy tmp 0)) + (gslist-free gslist)) (defmethod alien-type ((type (eql 'gslist)) &rest args) (declare (ignore type args)) @@ -298,7 +290,7 @@ `(let ((gslist ,gslist)) (unwind-protect (map-glist 'list #'identity gslist ',element-type) - (gslist-free gslist))))) + (destroy-gslist gslist ',element-type))))) (defmethod from-alien-function ((type (eql 'gslist)) &rest args) (declare (ignore type)) @@ -306,16 +298,52 @@ #'(lambda (gslist) (unwind-protect (map-glist 'list #'identity gslist element-type) - (gslist-free gslist))))) + (destroy-gslist gslist element-type))))) -(defmethod cleanup-form (list (type (eql 'gslist)) &rest args) - (declare (ignore type args)) - `(gslist-free ,list)) +(defmethod copy-from-alien-form (gslist (type (eql 'gslist)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + `(map-glist 'list #'identity ,gslist ',element-type))) + +(defmethod from-alien-function ((type (eql 'gslist)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + #'(lambda (gslist) + (map-glist 'list #'identity gslist element-type)))) + +(defmethod cleanup-form (gslist (type (eql 'gslist)) &rest 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)) - #'gslist-free) + (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 @@ -324,11 +352,19 @@ (let* ((size-of-type (size-of type)) (location (or location (allocate-memory (* size-of-type length)))) (writer (writer-function type))) - (loop - for element across content - for i from 0 below length - as offset = 0 then (+ offset size-of-type) - do (funcall writer element location offset)) + (etypecase content + (vector + (loop + for element across content + for i from 0 below length + as offset = 0 then (+ offset size-of-type) + do (funcall writer element location offset))) + (list + (loop + for element in content + for i from 0 below length + as offset = 0 then (+ offset size-of-type) + do (funcall writer element location offset)))) location)) @@ -357,6 +393,16 @@ finally (return sequence)))))) +(defun destroy-c-vector (location element-type length) + (loop + with destroy = (destroy-function element-type) + with element-size = (size-of element-type) + for i from 0 below length + as offset = 0 then (+ offset element-size) + do (funcall destroy location offset)) + (deallocate-memory location)) + + (defmethod alien-type ((type (eql 'vector)) &rest args) (declare (ignore type args)) (alien-type 'pointer)) @@ -380,12 +426,22 @@ location) `(make-c-vector ',element-type ,length ,vector)))) -(defmethod from-alien-form (location (type (eql 'vector)) &rest args) +(defmethod from-alien-form (c-vector (type (eql 'vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type &optional (length '*)) args + (if (eq length '*) + (error "Can't use vector of variable size as return type") + `(let ((c-vector ,c-vector)) + (prog1 + (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) (declare (ignore type)) (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 ,location)))) + `(map-c-vector 'vector #'identity ,c-vector ',element-type ',length)))) (defmethod cleanup-form (location (type (eql 'vector)) &rest args) (declare (ignore type)) @@ -402,3 +458,32 @@ (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)))))))