X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/4e94e04b3254f38fa8ce7b43261058cd3b671025..a90441812ae6371c08c3e3cb6eac47168115b9c7:/glib/glib.lisp diff --git a/glib/glib.lisp b/glib/glib.lisp index 891196a..d168a46 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.2 2000-08-15 23:25:18 espen Exp $ +;; $Id: glib.lisp,v 1.7 2000-10-05 17:17:41 espen Exp $ (in-package "GLIB") @@ -40,22 +40,71 @@ (defun copy-memory (from length &optional (to (allocate-memory length))) -;;;; Linked list +;;;; Quarks -(deftype glist () 'pointer) -(deftype double-list (type) `(or (null (cons ,type list)))) +(deftype quark () 'unsigned) +;(define-foreign %quark-get-reserved () quark) -(define-foreign ("g_list_append" %glist-append) () glist - (glist glist) +(define-foreign %quark-from-string () quark + (string string)) + +(defvar *string-counter* 0) + +(defun %quark-get-reserved () + (%quark-from-string (format nil "CLG-~D" (incf *string-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*)))) + + + +;;;; Linked list (GList) + +(deftype glist (type) `(or (null (cons ,type list)))) + +(define-foreign ("g_list_append" %glist-append-unsigned) () pointer + (glist pointer) (data unsigned)) +(define-foreign ("g_list_append" %glist-append-signed) () pointer + (glist pointer) + (data signed)) + +(define-foreign ("g_list_append" %glist-append-sap) () pointer + (glist pointer) + (data pointer)) + (defmacro glist-append (glist value type-spec) (ecase (first (mklist (translate-type-spec type-spec))) - (unsigned `(%glist-append ,glist ,value)) -; (signed `(%glist-append ,glist (signed-to-unsigned ,value))) - (system-area-pointer `(%glist-append ,glist (system:sap-int ,value))))) - + (unsigned `(%glist-append-unsigned ,glist ,value)) + (signed `(%glist-append-signed ,glist ,value)) + (system-area-pointer `(%glist-append-sap ,glist ,value)))) (defmacro glist-data (glist type-spec) (ecase (first (mklist (translate-type-spec type-spec))) @@ -63,32 +112,32 @@ (defmacro glist-data (glist type-spec) (signed `(sap-ref-signed ,glist 0)) (system-area-pointer `(sap-ref-sap ,glist 0)))) - (defun glist-next (glist) (unless (null-pointer-p glist) (sap-ref-sap glist +size-of-sap+))) - (define-foreign ("g_list_free" glist-free) () nil (glist pointer)) +(deftype-method translate-type-spec glist (type-spec) + (declare (ignore type-spec)) + (translate-type-spec 'pointer)) -(deftype-method translate-type-spec double-list (type-spec) +(deftype-method size-of glist (type-spec) (declare (ignore type-spec)) - 'system-area-pointer) + (size-of 'pointer)) -(deftype-method translate-to-alien double-list (type-spec list &optional copy) +(deftype-method translate-to-alien glist (type-spec list &optional copy) (declare (ignore copy)) - (let* ((element-type-spec (second (type-expand-to 'double-list type-spec))) + (let* ((element-type-spec (second (type-expand-to 'glist type-spec))) (to-alien (translate-to-alien element-type-spec 'element t))) `(let ((glist (make-pointer 0))) (dolist (element ,list glist) (setq glist (glist-append glist ,to-alien ,element-type-spec)))))) -(deftype-method - translate-from-alien - double-list (type-spec glist &optional (alloc :dynamic)) - (let ((element-type-spec (second (type-expand-to 'double-list type-spec)))) +(deftype-method translate-from-alien + glist (type-spec glist &optional (alloc :reference)) + (let ((element-type-spec (second (type-expand-to 'glist type-spec)))) `(let ((glist ,glist) (list nil)) (do ((tmp glist (glist-next tmp))) @@ -97,13 +146,13 @@ (deftype-method ,(translate-from-alien element-type-spec `(glist-data tmp ,element-type-spec) alloc) list)) - ,(when (eq alloc :dynamic) + ,(when (eq alloc :reference) '(glist-free glist)) (nreverse list)))) -(deftype-method cleanup-alien double-list (type-spec glist &optional copied) +(deftype-method cleanup-alien glist (type-spec glist &optional copied) (declare (ignore copied)) - (let* ((element-type-spec (second (type-expand-to 'double-list type-spec))) + (let* ((element-type-spec (second (type-expand-to 'glist type-spec))) (alien-type-spec (translate-type-spec element-type-spec))) `(let ((glist ,glist)) (unless (null-pointer-p glist) @@ -116,80 +165,124 @@ (deftype-method cleanup-alien double-list (type-spec glist &optional copied) -;;; Array -#| -(define-foreign ("g_array_new" %array-new) () garray - (zero-terminated boolean) - (clear boolean) - (element-size unsigned-int)) - -(defun array-new (&key zero-terminated clear (element-size 4) initial-contents) - (let ((array (%array-new zero-terminated clear element-size))) - (when initial-contents - (dolist (element initial-contents) - (array-append array element))) - array)) - -(define-foreign ("g_array_free" %array-free) () none - (array garray) - (free-segment boolean)) - -(defun array-free (array &optional free-data (free-segment t)) - (when free-data - (dotimes (i (array-get-size array)) - (free (array-get-pointer array i)))) - (%array-free array free-segment)) - -(defmacro with-array (binding &body body) - (let ((array (gensym))) - (destructuring-bind (var &rest args - &key (free-contents nil) (free-segment t) - &allow-other-keys ) - binding - (remf args :free-contents) - (remf args :free-segment) - `(let* ((,array (array-new ,@args)) - (,var (array-get-data ,array))) - (unwind-protect - ,@body - (array-free ,array ,free-contents ,free-segment)))))) - -;; cl-gtk.c -(define-foreign ("g_array_insert_int" array-insert-int) () garray - (array garray) - (index unsigned-int) - (value int)) - -(defun array-insert-value (array index value) - (etypecase value - (null (array-insert-int array index 0)) - (integer (array-insert-int array index value)) - (string (array-insert-int array index (sap-int (gforeign::pointer-to-sap (%strdup value))))) - (pointer (array-insert-int array index (sap-int (gforeign::pointer-to-sap value)))))) - -(defun array-prepend (array value) - (array-insert-value array 0 value)) - -(defun array-append (array value) - (array-insert-value array (array-get-size array) value)) - -;; cl-gtk.c -(define-foreign ("g_array_get_int" array-get-int) () int - (array garray) - (index unsigned-int)) - -(defun array-get-pointer (array index) - (gforeign::sap-to-pointer (int-sap (array-get-int array index)))) - -;; cl-gtk.c -(define-foreign ("g_array_get_data" array-get-data) () pointer - (array garray)) - -(define-foreign ("g_array_set_size" array-set-size) () garray - (array garray) - (size unsigned-int)) - -;; cl-gtk.c -(define-foreign ("g_array_get_size" array-get-size) () int - (array garray)) -|# \ No newline at end of file +;;;; Single linked list (GSList) + +(deftype gslist (type) `(or (null (cons ,type list)))) + +(define-foreign ("g_slist_prepend" %gslist-prepend-unsigned) () pointer + (gslist pointer) + (data unsigned)) + +(define-foreign ("g_slist_prepend" %gslist-prepend-signed) () pointer + (gslist pointer) + (data signed)) + +(define-foreign ("g_slist_prepend" %gslist-prepend-sap) () pointer + (gslist pointer) + (data pointer)) + +(defmacro gslist-prepend (gslist value type-spec) + (ecase (first (mklist (translate-type-spec type-spec))) + (unsigned `(%gslist-prepend-unsigned ,gslist ,value)) + (signed `(%gslist-prepend-signed ,gslist ,value)) + (system-area-pointer `(%gslist-prepend-sap ,gslist ,value)))) + +(define-foreign ("g_slist_free" gslist-free) () nil + (gslist pointer)) + +(deftype-method translate-type-spec gslist (type-spec) + (declare (ignore type-spec)) + (translate-type-spec 'pointer)) + +(deftype-method size-of gslist (type-spec) + (declare (ignore type-spec)) + (size-of 'pointer)) + +(deftype-method translate-to-alien gslist (type-spec list &optional copy) + (declare (ignore copy)) + (let* ((element-type-spec (second (type-expand-to 'gslist type-spec))) + (to-alien (translate-to-alien element-type-spec 'element t))) + `(let ((gslist (make-pointer 0))) + (dolist (element (reverse ,list) gslist) + (setq gslist (gslist-prepend gslist ,to-alien ,element-type-spec)))))) + +(deftype-method translate-from-alien + gslist (type-spec gslist &optional (alloc :reference)) + (let ((element-type-spec (second (type-expand-to 'gslist type-spec)))) + `(let ((gslist ,gslist) + (list nil)) + (do ((tmp gslist (glist-next tmp))) + ((null-pointer-p tmp)) + (push + ,(translate-from-alien + element-type-spec `(glist-data tmp ,element-type-spec) alloc) + list)) + ,(when (eq alloc :reference) + '(gslist-free gslist)) + (nreverse list)))) + +(deftype-method cleanup-alien gslist (type-spec gslist &optional copied) + (declare (ignore copied)) + (let* ((element-type-spec (second (type-expand-to 'gslist type-spec))) + (alien-type-spec (translate-type-spec element-type-spec))) + `(let ((gslist ,gslist)) + (unless (null-pointer-p gslist) + ,(when (eq alien-type-spec 'system-area-pointer) + `(do ((tmp gslist (glist-next tmp))) + ((null-pointer-p tmp)) + ,(cleanup-alien + element-type-spec `(glist-data tmp ,element-type-spec) t))) + (gslist-free gslist))))) + + + +;;; Vector + +(deftype-method translate-type-spec vector (type-spec) + (declare (ignore type-spec)) + (translate-type-spec 'pointer)) + +(deftype-method size-of vector (type-spec) + (declare (ignore type-spec)) + (size-of 'pointer)) + +(deftype-method translate-to-alien vector (type-spec vector &optional copy) + (declare (ignore copy)) + (destructuring-bind (element-type &optional (length '*)) + (cdr (type-expand-to 'vector type-spec)) + (let ((element-size (size-of element-type))) + `(let ((vector ,vector)) + (let ((c-vector + (allocate-memory + ,(if (eq length '*) + `(* ,element-size (length vector)) + (* element-size length))))) + (dotimes (i ,(if (eq length '*) '(length vector) length) c-vector) + (setf + (,(sap-ref-fname element-type) c-vector (* i ,element-size)) + ,(translate-to-alien element-type '(aref vector i) :copy)))))))) + +(deftype-method translate-from-alien + vector (type-spec sap &optional (alloc :reference)) + (destructuring-bind (element-type &optional (length '*)) + (cdr (type-expand-to 'vector type-spec)) + (when (eq length '*) + (error "Can't use vectors of variable length as return type")) + (let ((element-size (size-of element-type))) + `(let ((sap ,sap) + (vector (make-array ,length :element-type ',element-type))) + (dotimes (i ,length vector) + (setf + (aref vector i) + ,(translate-to-alien + element-type + `(,(sap-ref-fname element-type) sap (* i ,element-size)) + alloc))))))) + + +(deftype-method cleanup-alien vector (type-spec sap &optional copied) + (declare (ignore type-spec copied)) + ;; The individual elements also have to be cleaned up to avoid memory leaks, + ;; but this is currently not possible because we can't always tell the + ;; length of the vector + `(deallocate-memory ,sap))