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