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