X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/16bf114944d819b3041f89d033a824373641d9f7..f4ba8dcb96baefeab615d39c901769b7136e32aa:/glib/glib.lisp diff --git a/glib/glib.lisp b/glib/glib.lisp index 6c2a90b..7ce7218 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.21 2004-12-09 23:31:50 espen Exp $ +;; $Id: glib.lisp,v 1.25 2005-02-03 23:09:04 espen Exp $ (in-package "GLIB") @@ -38,7 +38,9 @@ ;; (declare (ignore address))) (defun copy-memory (from length &optional (to (allocate-memory length))) - (kernel:system-area-copy from 0 to 0 (* 8 length)) + (;#+cmu kernel:system-area-copy + ;#+sbcl sb-impl::system-area-copy + system-area-copy from 0 to 0 (* 8 length)) to) @@ -46,8 +48,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 +64,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*))) @@ -74,49 +87,21 @@ ;;;; 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) @@ -225,11 +210,35 @@ `(destroy-glist ,glist ',element-type))) (defmethod cleanup-function ((type (eql 'glist)) &rest args) - (declare (ignore type args)) + (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))))) + +(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)))))) + + ;;;; Single linked list (GSList) @@ -298,23 +307,45 @@ (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) (map-glist 'list #'identity gslist element-type)))) (defmethod cleanup-form (gslist (type (eql 'gslist)) &rest args) - (declare (ignore type 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)) + (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 @@ -404,7 +435,7 @@ (error "Can't use vector of variable size as return type") `(let ((c-vector ,c-vector)) (prog1 - (map-c-vector 'vector #'identity ',element-type ,length c-vector) + (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) @@ -412,7 +443,7 @@ (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 ,c-vector)))) + `(map-c-vector 'vector #'identity ,c-vector ',element-type ',length)))) (defmethod cleanup-form (location (type (eql 'vector)) &rest args) (declare (ignore type))