From: espen Date: Thu, 5 Oct 2000 17:17:41 +0000 (+0000) Subject: Added single linked list type (gslist), changed name of double linked list type to... X-Git-Url: https://git.distorted.org.uk/~mdw/clg/commitdiff_plain/3846c0b6c0926c3f01db6474c16f511455c45725 Added single linked list type (gslist), changed name of double linked list type to glist, enhanced vector type. --- diff --git a/glib/glib.lisp b/glib/glib.lisp index 5a5fcb0..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.6 2000-09-04 22:10:26 espen Exp $ +;; $Id: glib.lisp,v 1.7 2000-10-05 17:17:41 espen Exp $ (in-package "GLIB") @@ -84,22 +84,27 @@ -;;;; Linked list +;;;; Linked list (GList) -(deftype glist () 'pointer) -(deftype double-list (type) `(or (null (cons ,type list)))) +(deftype glist (type) `(or (null (cons ,type list)))) - -(define-foreign ("g_list_append" %glist-append) () glist - (glist glist) +(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))) @@ -107,36 +112,32 @@ (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 double-list (type-spec) +(deftype-method translate-type-spec glist (type-spec) (declare (ignore type-spec)) (translate-type-spec 'pointer)) -(deftype-method size-of double-list (type-spec) +(deftype-method size-of glist (type-spec) (declare (ignore type-spec)) (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 :reference)) - (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))) @@ -149,9 +150,9 @@ '(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) @@ -164,6 +165,77 @@ +;;;; 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) @@ -178,8 +250,7 @@ (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 ((element-size (size-of element-type))) `(let ((vector ,vector)) (let ((c-vector (allocate-memory @@ -189,7 +260,25 @@ (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)))))))) + ,(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))