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