X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/0aef1da83378c41306f31f5cb9f29681baea38e9..1ebfd3a68309e369abf0b2db8283928dd72b61a2:/glib/glib.lisp diff --git a/glib/glib.lisp b/glib/glib.lisp index 4af0e94..5a5fcb0 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.3 2000-08-22 23:13:39 espen Exp $ +;; $Id: glib.lisp,v 1.6 2000-09-04 22:10:26 espen Exp $ (in-package "GLIB") @@ -44,7 +44,15 @@ (defun copy-memory (from length &optional (to (allocate-memory length))) (deftype quark () 'unsigned) -(define-foreign %quark-get-reserved () quark) +;(define-foreign %quark-get-reserved () quark) + +(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)) @@ -54,7 +62,11 @@ (defun quark-from-object (object &key (test #'eq)) (or (assoc-ref object (gethash hash-code *quark-from-object*) :test test) (let ((quark (%quark-get-reserved))) - (push (cons object quark) (gethash hash-code *quark-from-object*)) + (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)))) @@ -107,7 +119,11 @@ (define-foreign ("g_list_free" glist-free) () nil (deftype-method translate-type-spec double-list (type-spec) (declare (ignore type-spec)) - 'system-area-pointer) + (translate-type-spec 'pointer)) + +(deftype-method size-of double-list (type-spec) + (declare (ignore type-spec)) + (size-of 'pointer)) (deftype-method translate-to-alien double-list (type-spec list &optional copy) (declare (ignore copy)) @@ -119,7 +135,7 @@ (deftype-method translate-to-alien double-list (type-spec list &optional copy) (deftype-method translate-from-alien - double-list (type-spec glist &optional (alloc :dynamic)) + double-list (type-spec glist &optional (alloc :reference)) (let ((element-type-spec (second (type-expand-to 'double-list type-spec)))) `(let ((glist ,glist) (list nil)) @@ -129,7 +145,7 @@ (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)))) @@ -148,80 +164,36 @@ (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 +;;; 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-to-alien (translate-to-alien element-type 'element :copy)) + (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 '(svref vector i) :copy)))))))) + +(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))