X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/7e531ed54c9e67aa5a6f181dfe85c54ec7e5176c..56ccd5b731e30f2d195cefc4cbf0b8640fac2c92:/glib/glib.lisp diff --git a/glib/glib.lisp b/glib/glib.lisp index 20fbc89..0caa70d 100644 --- a/glib/glib.lisp +++ b/glib/glib.lisp @@ -1,21 +1,26 @@ -;; Common Lisp bindings for GTK+ v1.2.x -;; Copyright (C) 1999 Espen S. Johnsen +;; Common Lisp bindings for GTK+ 2.x +;; Copyright 1999-2005 Espen S. Johnsen ;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2 of the License, or (at your option) any later version. +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: ;; -;; This library is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; Lesser General Public License for more details. +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. ;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: glib.lisp,v 1.24 2005-01-30 14:26:41 espen Exp $ +;; $Id: glib.lisp,v 1.34 2006-02-15 09:53:42 espen Exp $ (in-package "GLIB") @@ -38,9 +43,21 @@ ;; (declare (ignore address))) (defun copy-memory (from length &optional (to (allocate-memory length))) - (kernel:system-area-copy from 0 to 0 (* 8 length)) + #+cmu(system-area-copy from 0 to 0 (* 8 length)) + #+sbcl(system-area-ub8-copy from 0 to 0 length) to) +(defmacro with-allocated-memory ((var size) &body body) + (if (constantp size) + (let ((alien (make-symbol "ALIEN"))) + `(with-alien ((,alien (array #+sbcl(sb-alien:unsigned 8) #+cmu(alien:unsigned 8) ,(eval size)))) + (let ((,var (alien-sap ,alien))) + ,@body))) + `(let ((,var (allocate-memory ,size))) + (unwind-protect + (progn ,@body) + (deallocate-memory ,var))))) + ;;;; User data mechanism @@ -224,7 +241,8 @@ (defmethod reader-function ((type (eql 'glist)) &rest args) (declare (ignore type)) (destructuring-bind (element-type) args - #'(lambda (location &optional (offset 0)) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (unless (null-pointer-p (sap-ref-sap location offset)) (map-glist 'list #'identity (sap-ref-sap location offset) element-type))))) @@ -305,7 +323,7 @@ (destructuring-bind (element-type) args `(map-glist 'list #'identity ,gslist ',element-type))) -(defmethod from-alien-function ((type (eql 'gslist)) &rest args) +(defmethod copy-from-alien-function ((type (eql 'gslist)) &rest args) (declare (ignore type)) (destructuring-bind (element-type) args #'(lambda (gslist) @@ -333,7 +351,8 @@ (defmethod reader-function ((type (eql 'gslist)) &rest args) (declare (ignore type)) (destructuring-bind (element-type) args - #'(lambda (location &optional (offset 0)) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (unless (null-pointer-p (sap-ref-sap location offset)) (map-glist 'list #'identity (sap-ref-sap location offset) element-type))))) @@ -441,7 +460,15 @@ (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 ,c-vector ',element-type ',length)))) + `(map-c-vector 'vector #'identity ,c-vector ',element-type ,length)))) + +(defmethod copy-from-alien-function ((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") + #'(lambda (c-vector) + (map-c-vector 'vector #'identity c-vector element-type length))))) (defmethod cleanup-form (location (type (eql 'vector)) &rest args) (declare (ignore type)) @@ -472,7 +499,8 @@ (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)) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (unless (null-pointer-p (sap-ref-sap location offset)) (map-c-vector 'vector #'identity (sap-ref-sap location offset) element-type length)))))) @@ -487,3 +515,221 @@ (destroy-c-vector (sap-ref-sap location offset) element-type length) (setf (sap-ref-sap location offset) (make-pointer 0))))))) + + +;;;; Null terminated vector + +(defun make-0-vector (type content &optional location) + (let* ((size-of-type (size-of type)) + (location (or + location + (allocate-memory (* size-of-type (1+ (length content)))))) + (writer (writer-function type))) + (etypecase content + (vector + (loop + for element across content + as offset = 0 then (+ offset size-of-type) + do (funcall writer element location offset) + finally (setf (sap-ref-sap location offset) (make-pointer 0)))) + (list + (loop + for element in content + as offset = 0 then (+ offset size-of-type) + do (funcall writer element location offset) + finally (setf (sap-ref-sap location (+ offset size-of-type)) (make-pointer 0))))) + location)) + + +(defun map-0-vector (seqtype function location element-type) + (let ((reader (reader-function element-type)) + (size-of-element (size-of element-type))) + (case seqtype + ((nil) + (loop + as offset = 0 then (+ offset size-of-element) + until (null-pointer-p (sap-ref-sap location offset)) + do (funcall function (funcall reader location offset)))) + (list + (loop + as offset = 0 then (+ offset size-of-element) + until (null-pointer-p (sap-ref-sap location offset)) + collect (funcall function (funcall reader location offset)))) + (t + (coerce + (loop + as offset = 0 then (+ offset size-of-element) + until (null-pointer-p (sap-ref-sap location offset)) + collect (funcall function (funcall reader location offset))) + seqtype))))) + + +(defun destroy-0-vector (location element-type) + (loop + with destroy = (destroy-function element-type) + with element-size = (size-of element-type) + as offset = 0 then (+ offset element-size) + until (null-pointer-p (sap-ref-sap location offset)) + do (funcall destroy location offset)) + (deallocate-memory location)) + +(deftype null-terminated-vector (element-type) `(vector ,element-type)) + +(defmethod alien-type ((type (eql 'null-terminated-vector)) &rest args) + (declare (ignore type args)) + (alien-type 'pointer)) + +(defmethod size-of ((type (eql 'null-terminated-vector)) &rest args) + (declare (ignore type args)) + (size-of 'pointer)) + +(defmethod to-alien-form (vector (type (eql 'null-terminated-vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + `(make-0-vector ',element-type ,vector))) + +(defmethod from-alien-form (c-vector (type (eql 'null-terminated-vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + `(let ((c-vector ,c-vector)) + (prog1 + (map-0-vector 'vector #'identity c-vector ',element-type) + (destroy-0-vector c-vector ',element-type))))) + +(defmethod copy-from-alien-form (c-vector (type (eql 'null-terminated-vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + `(map-0-vector 'vector #'identity ,c-vector ',element-type))) + +(defmethod cleanup-form (location (type (eql 'null-terminated-vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + `(destroy-0-vector ,location ',element-type))) + +(defmethod writer-function ((type (eql 'null-terminated-vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + (unless (eq (alien-type element-type) (alien-type 'pointer)) + (error "Elements in null-terminated vectors need to be of pointer types")) + #'(lambda (vector location &optional (offset 0)) + (setf + (sap-ref-sap location offset) + (make-0-vector element-type vector))))) + +(defmethod reader-function ((type (eql 'null-terminated-vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + (unless (eq (alien-type element-type) (alien-type 'pointer)) + (error "Elements in null-terminated vectors need to be of pointer types")) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) + (unless (null-pointer-p (sap-ref-sap location offset)) + (map-0-vector 'vector #'identity (sap-ref-sap location offset) + element-type))))) + +(defmethod destroy-function ((type (eql 'null-terminated-vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + (unless (eq (alien-type element-type) (alien-type 'pointer)) + (error "Elements in null-terminated vectors need to be of pointer types")) + #'(lambda (location &optional (offset 0)) + (unless (null-pointer-p (sap-ref-sap location offset)) + (destroy-0-vector + (sap-ref-sap location offset) element-type) + (setf (sap-ref-sap location offset) (make-pointer 0)))))) + +(defmethod unbound-value ((type (eql 'null-terminated-vector)) &rest args) + (declare (ignore type args)) + (values t nil)) + + +;;; Counted vector + +(defun make-counted-vector (type content) + (let* ((size-of-type (size-of type)) + (length (length content)) + (location + (allocate-memory (+ +size-of-int+ (* size-of-type length))))) + (setf (sap-ref-32 location 0) length) + (make-c-vector type length content (sap+ location +size-of-int+)))) + +(defun map-counted-vector (seqtype function location element-type) + (let ((length (sap-ref-32 location 0))) + (map-c-vector + seqtype function (sap+ location +size-of-int+) + element-type length))) + +(defun destroy-counted-vector (location element-type) + (loop + with destroy = (destroy-function element-type) + with element-size = (size-of element-type) + for i from 0 below (sap-ref-32 location 0) + as offset = +size-of-int+ then (+ offset element-size) + do (funcall destroy location offset)) + (deallocate-memory location)) + + +(deftype counted-vector (element-type) `(vector ,element-type)) + +(defmethod alien-type ((type (eql 'counted-vector)) &rest args) + (declare (ignore type args)) + (alien-type 'pointer)) + +(defmethod size-of ((type (eql 'counted-vector)) &rest args) + (declare (ignore type args)) + (size-of 'pointer)) + +(defmethod to-alien-form (vector (type (eql 'counted-vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + `(make-counted-vector ',element-type ,vector))) + +(defmethod from-alien-form (c-vector (type (eql 'counted-vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + `(let ((c-vector ,c-vector)) + (prog1 + (map-counted-vector 'vector #'identity c-vector ',element-type) + (destroy-counted-vector c-vector ',element-type))))) + +(defmethod copy-from-alien-form (c-vector (type (eql 'counted-vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + `(map-counted-vector 'vector #'identity ,c-vector ',element-type))) + +(defmethod copy-from-alien-function ((type (eql 'counted-vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + #'(lambda (c-vector) + (map-counted-vector 'vector #'identity c-vector element-type)))) + +(defmethod cleanup-form (location (type (eql 'counted-vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + `(destroy-counted-vector ,location ',element-type))) + +(defmethod writer-function ((type (eql 'counted-vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + #'(lambda (vector location &optional (offset 0)) + (setf + (sap-ref-sap location offset) + (make-counted-vector element-type vector))))) + +(defmethod reader-function ((type (eql 'counted-vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) + (unless (null-pointer-p (sap-ref-sap location offset)) + (map-counted-vector 'vector #'identity + (sap-ref-sap location offset) element-type))))) + +(defmethod destroy-function ((type (eql 'counted-vector)) &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-counted-vector + (sap-ref-sap location offset) element-type) + (setf (sap-ref-sap location offset) (make-pointer 0))))))