chiark - git - mdw - clg/blob - glib/glib.lisp

   1 ;; Common Lisp bindings for GTK+ v1.2.x
   2 ;; Copyright (C) 1999 Espen S. Johnsen <espejohn@online.no>
   3 ;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; $Id: glib.lisp,v 1.15 2004-11-01 00:08:49 espen Exp $
  19
  20
  21 (in-package "GLIB")
  22
  23 (use-prefix "g")
  24
  25
  26 ;;;; Memory management
  27
  28 (defbinding (allocate-memory "g_malloc0") () pointer
  29   (size unsigned-long))
  30
  31 (defbinding (reallocate-memory "g_realloc") () pointer
  32   (address pointer)
  33   (size unsigned-long))
  34
  35 (defbinding (deallocate-memory "g_free") () nil
  36   (address pointer))
  37 ;(defun deallocate-memory (address)
  38 ;  (declare (ignore address)))
  39
  40 (defun copy-memory (from length &optional (to (allocate-memory length)))
  41   (kernel:system-area-copy from 0 to 0 (* 8 length))
  42   to)
  43
  44
  45 ;;;; User data mechanism
  46
  47 (internal *user-data* *user-data-count*)
  48
  49 (declaim (fixnum *user-data-count*))
  50
  51 (defvar *user-data* (make-hash-table))
  52 (defvar *user-data-count* 0)
  53
  54 (defun register-user-data (object &optional destroy-function)
  55   (check-type destroy-function (or null symbol function))
  56   (incf *user-data-count*)
  57   (setf
  58    (gethash *user-data-count* *user-data*)
  59    (cons object destroy-function))
  60   *user-data-count*)
  61
  62 (defun find-user-data (id)
  63   (check-type id fixnum)
  64   (multiple-value-bind (user-data p) (gethash id *user-data*)
  65     (values (car user-data) p)))
  66
  67 (defun destroy-user-data (id)
  68   (check-type id fixnum)
  69   (let ((user-data (gethash id *user-data*)))
  70     (when (cdr user-data)
  71       (funcall (cdr user-data) (car user-data))))
  72   (remhash id *user-data*))
  73
  74
  75
  76 ;;;; Quarks
  77
  78 (internal *quark-counter* *quark-from-object* *quark-to-object*)
  79
  80 (deftype quark () 'unsigned)
  81
  82 ;(defbinding %quark-get-reserved () quark)
  83
  84 (defbinding %quark-from-string () quark
  85   (string string))
  86
  87 (defvar *quark-counter* 0)
  88
  89 (defun %quark-get-reserved ()
  90   ;; The string is just a dummy
  91   (%quark-from-string (format nil "#@£$%&-quark-~D" (incf *quark-counter*))))
  92
  93 (defvar *quark-from-object* (make-hash-table))
  94 (defvar *quark-to-object* (make-hash-table))
  95
  96 (defun quark-from-object (object &key (test #'eq))
  97   (let ((hash-code (sxhash object)))
  98     (or
  99      (assoc-ref object (gethash hash-code *quark-from-object*) :test test)
 100      (let ((quark (%quark-get-reserved)))
 101        (setf
 102         (gethash hash-code *quark-from-object*)
 103         (append
 104          (gethash hash-code *quark-from-object*)
 105          (list (cons object quark))))
 106        (setf (gethash quark *quark-to-object*) object)
 107        quark))))
 108
 109 (defun quark-to-object (quark)
 110   (gethash quark *quark-to-object*))
 111
 112 (defun remove-quark (quark)
 113   (let* ((object (gethash quark *quark-to-object*))
 114          (hash-code (sxhash object)))
 115     (remhash quark *quark-to-object*)
 116     (unless (setf
 117              (gethash hash-code *quark-from-object*)
 118              (assoc-delete object (gethash hash-code *quark-from-object*)))
 119       (remhash hash-code *quark-from-object*))))
 120
 121
 122
 123 ;;;; Linked list (GList)
 124
 125 (deftype glist (type) `(or (null (cons ,type list))))
 126
 127 (defbinding (%glist-append-unsigned "g_list_append") () pointer
 128   (glist pointer)
 129   (data unsigned))
 130
 131 (defbinding (%glist-append-signed "g_list_append") () pointer
 132   (glist pointer)
 133   (data signed))
 134
 135 (defbinding (%glist-append-sap "g_list_append") () pointer
 136   (glist pointer)
 137   (data pointer))
 138
 139 (defmacro glist-append (glist value type-spec)
 140   (ecase (first (mklist (translate-type-spec type-spec)))
 141     (unsigned `(%glist-append-unsigned ,glist ,value))
 142     (signed `(%glist-append-signed ,glist ,value))
 143     (system-area-pointer `(%glist-append-sap ,glist ,value))))
 144
 145 (defmacro glist-data (glist type-spec)
 146   (ecase (first (mklist (translate-type-spec type-spec)))
 147     (unsigned `(sap-ref-unsigned ,glist 0))
 148     (signed `(sap-ref-signed ,glist 0))
 149     (system-area-pointer `(sap-ref-sap ,glist 0))))
 150
 151 (defun glist-next (glist)
 152   (unless (null-pointer-p glist)
 153     (sap-ref-sap glist +size-of-sap+)))
 154
 155 (defbinding (glist-free "g_list_free") () nil
 156   (glist pointer))
 157
 158 (deftype-method translate-type-spec glist (type-spec)
 159   (declare (ignore type-spec))
 160   (translate-type-spec 'pointer))
 161
 162 (deftype-method size-of glist (type-spec)
 163   (declare (ignore type-spec))
 164   (size-of 'pointer))
 165
 166 (deftype-method translate-to-alien glist (type-spec list &optional weak-ref)
 167   (declare (ignore weak-ref))
 168   (let* ((element-type (second (type-expand-to 'glist type-spec)))
 169          (element (translate-to-alien element-type 'element)))
 170     `(let ((glist (make-pointer 0)))
 171        (dolist (element ,list glist)
 172          (setq glist (glist-append glist ,element ,element-type))))))
 173
 174 (deftype-method translate-from-alien
 175     glist (type-spec glist &optional weak-ref)
 176   (let ((element-type (second (type-expand-to 'glist type-spec))))
 177     `(let ((glist ,glist)
 178            (list nil))
 179        (do ((tmp glist (glist-next tmp)))
 180            ((null-pointer-p tmp))
 181          (push
 182           ,(translate-from-alien
 183             element-type `(glist-data tmp ,element-type) weak-ref)
 184           list))
 185        ,(unless weak-ref
 186           '(glist-free glist))
 187        (nreverse list))))
 188
 189 (deftype-method cleanup-alien glist (type-spec glist &optional weak-ref)
 190   (when weak-ref
 191     (unreference-alien type-spec glist)))
 192
 193 (deftype-method unreference-alien glist (type-spec glist)
 194   (let ((element-type (second (type-expand-to 'glist type-spec))))
 195     `(let ((glist ,glist))
 196        (unless (null-pointer-p glist)
 197          ,(unless (atomic-type-p element-type)
 198             `(do ((tmp glist (glist-next tmp)))
 199                  ((null-pointer-p tmp))
 200                ,(unreference-alien
 201                  element-type `(glist-data tmp ,element-type))))
 202          (glist-free glist)))))
 203
 204
 205 ;;;; Single linked list (GSList)
 206
 207 (deftype gslist (type) `(or (null (cons ,type list))))
 208
 209 (defbinding (%gslist-prepend-unsigned "g_slist_prepend") () pointer
 210   (gslist pointer)
 211   (data unsigned))
 212
 213 (defbinding (%gslist-prepend-signed "g_slist_prepend") () pointer
 214   (gslist pointer)
 215   (data signed))
 216
 217 (defbinding (%gslist-prepend-sap "g_slist_prepend") () pointer
 218   (gslist pointer)
 219   (data pointer))
 220
 221 (defmacro gslist-prepend (gslist value type-spec)
 222   (ecase (first (mklist (translate-type-spec type-spec)))
 223     (unsigned `(%gslist-prepend-unsigned ,gslist ,value))
 224     (signed `(%gslist-prepend-signed ,gslist ,value))
 225     (system-area-pointer `(%gslist-prepend-sap ,gslist ,value))))
 226
 227 (defbinding (gslist-free "g_slist_free") () nil
 228   (gslist pointer))
 229
 230 (deftype-method translate-type-spec gslist (type-spec)
 231   (declare (ignore type-spec))
 232   (translate-type-spec 'pointer))
 233
 234 (deftype-method size-of gslist (type-spec)
 235   (declare (ignore type-spec))
 236   (size-of 'pointer))
 237
 238 (deftype-method translate-to-alien gslist (type-spec list &optional weak-ref)
 239   (declare (ignore weak-ref))
 240   (let* ((element-type (second (type-expand-to 'gslist type-spec)))
 241          (element (translate-to-alien element-type 'element)))
 242     `(let ((gslist (make-pointer 0)))
 243        (dolist (element (reverse ,list) gslist)
 244          (setq gslist (gslist-prepend gslist ,element ,element-type))))))
 245
 246 (deftype-method translate-from-alien
 247     gslist (type-spec gslist &optional weak-ref)
 248   (let ((element-type (second (type-expand-to 'gslist type-spec))))
 249     `(let ((gslist ,gslist)
 250            (list nil))
 251        (do ((tmp gslist (glist-next tmp)))
 252            ((null-pointer-p tmp))
 253          (push
 254           ,(translate-from-alien
 255             element-type `(glist-data tmp ,element-type) weak-ref)
 256           list))
 257        ,(unless weak-ref
 258           '(gslist-free gslist))
 259        (nreverse list))))
 260
 261 (deftype-method cleanup-alien gslist (type-spec gslist &optional weak-ref)
 262   (when weak-ref
 263     (unreference-alien type-spec gslist)))
 264
 265 (deftype-method unreference-alien gslist (type-spec gslist)
 266   (let ((element-type (second (type-expand-to 'gslist type-spec))))
 267     `(let ((gslist ,gslist))
 268        (unless (null-pointer-p gslist)
 269          ,(unless (atomic-type-p element-type)
 270             `(do ((tmp gslist (glist-next tmp)))
 271                  ((null-pointer-p tmp))
 272                ,(unreference-alien
 273                  element-type `(glist-data tmp ,element-type))))
 274          (gslist-free gslist)))))
 275
 276
 277
 278 ;;; Vector
 279
 280 (defvar *magic-end-of-array* (allocate-memory 1))
 281
 282 (deftype-method translate-type-spec vector (type-spec)
 283   (declare (ignore type-spec))
 284   (translate-type-spec 'pointer))
 285
 286 (deftype-method size-of vector (type-spec)
 287   (declare (ignore type-spec))
 288   (size-of 'pointer))
 289
 290 (deftype-method translate-to-alien vector (type-spec vector &optional weak-ref)
 291   (declare (ignore weak-ref))
 292   (destructuring-bind (element-type &optional (length '*))
 293       (cdr (type-expand-to 'vector type-spec))
 294     (let* ((element-size (size-of element-type))
 295            (size (cond
 296                   ((not (eq length '*))
 297                    (* element-size length))
 298                   ((not (atomic-type-p element-type))
 299                    `(* ,element-size (1+ (length vector))))
 300                   (t
 301                    `(* ,element-size (length vector))))))
 302
 303       `(let ((vector ,vector))
 304          (let ((c-vector (allocate-memory ,size)))
 305            (dotimes (i ,(if (eq length '*) '(length vector) length))
 306              (setf
 307               (,(sap-ref-fname element-type) c-vector (* i ,element-size))
 308               ,(translate-to-alien element-type '(aref vector i))))
 309            ,(when (and
 310                    (eq length '*)
 311                    (not (atomic-type-p element-type)))
 312               `(setf
 313                 (sap-ref-sap c-vector (* (length vector) ,element-size))
 314                 *magic-end-of-array*))
 315            c-vector)))))
 316
 317 (deftype-method translate-from-alien
 318     vector (type-spec c-array &optional weak-ref)
 319   (destructuring-bind (element-type &optional (length '*))
 320       (cdr (type-expand-to 'vector type-spec))
 321     (when (eq length '*)
 322       (error "Can't use vectors of variable length as return type"))
 323     (let ((element-size (size-of element-type)))
 324       `(let ((c-array ,c-array)
 325              (vector (make-array ,length :element-type ',element-type)))
 326          (dotimes (i ,length)
 327            (setf
 328             (aref vector i)
 329             ,(translate-from-alien
 330               element-type
 331               `(,(sap-ref-fname element-type) c-array (* i ,element-size))
 332               weak-ref)))
 333          ,(unless weak-ref
 334             '(deallocate-memory c-vector))
 335          vector))))
 336
 337
 338 (deftype-method cleanup-alien vector (type-spec c-vector &optional weak-ref)
 339   (when weak-ref
 340     (unreference-alien type-spec c-vector)))
 341
 342 (deftype-method unreference-alien vector (type-spec c-vector)
 343   (destructuring-bind (element-type &optional (length '*))
 344       (cdr (type-expand-to 'vector type-spec))
 345     `(let ((c-vector ,c-vector))
 346        (unless (null-pointer-p c-vector)
 347          ,(unless (atomic-type-p element-type)
 348             (let ((element-size (size-of element-type)))
 349               (if (not (eq length '*))
 350                   `(dotimes (i ,length)
 351                      (unreference-alien
 352                       element-type (sap-ref-sap c-vector (* i ,element-size))))
 353                 `(do ((offset 0 (+ offset ,element-size)))
 354                       ((sap=
 355                         (sap-ref-sap c-vector offset)
 356                         *magic-end-of-array*))
 357                      ,(unreference-alien
 358                        element-type '(sap-ref-sap c-vector offset))))))
 359          (deallocate-memory c-vector)))))
 360
 361
 362 (defun map-c-array (seqtype function location element-type length)
 363   (let ((reader (intern-reader-function element-type))
 364         (size (size-of element-type)))
 365     (case seqtype
 366      ((nil)
 367       (dotimes (i length)
 368         (funcall function (funcall reader location (* i size)))))
 369      (list
 370       (let ((list nil))
 371         (dotimes (i length)
 372           (push (funcall function (funcall reader location (* i size))) list))
 373         (nreverse list)))
 374      (t
 375       (let ((sequence (make-sequence seqtype length)))
 376         (dotimes (i length)
 377           (setf
 378            (elt sequence i)
 379            (funcall function (funcall reader location (* i size)))))
 380         sequence)))))