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

   1 ;; Common Lisp bindings for GTK+ 2.x
   2 ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: glib.lisp,v 1.44 2008-10-08 18:11:12 espen Exp $
  24
  25
  26 (in-package "GLIB")
  27
  28 (use-prefix "g")
  29
  30 #-sb-thread
  31 (progn
  32   (defun make-mutex ()
  33     nil)
  34
  35   (defmacro with-mutex ((mutex) &body body)
  36     (declare (ignore mutex))
  37     `(progn ,@body)))
  38
  39
  40 ;;;; Memory management
  41
  42 (deftype gsize () 'unsigned-int)
  43
  44 (defbinding malloc0 () pointer
  45   (size gsize))
  46
  47 (defbinding free () nil
  48   (address pointer))
  49
  50 (setf *memory-allocator* #'malloc0)
  51 (setf *memory-deallocator* #'free)
  52
  53 (defbinding (reallocate-memory "g_realloc") () pointer
  54   (address pointer)
  55   (size gsize))
  56
  57 (defbinding (slice-alloc "g_slice_alloc0") () pointer
  58   (block-size gsize))
  59
  60 ;;;; User data is a mechanism to store references to lisp objects in
  61 ;;;; foreign code
  62
  63 (defvar *user-data-lock* (make-mutex))
  64 (defvar *user-data* (make-hash-table))
  65 (defvar *user-data-next-id* 1)
  66
  67 (defun register-user-data (object &optional destroy-function)
  68   (check-type destroy-function (or null symbol function))
  69   (with-mutex (*user-data-lock*)
  70     (setf
  71      (gethash *user-data-next-id* *user-data*)
  72      (cons object destroy-function))
  73     (1- (incf *user-data-next-id*))))
  74
  75 (defun find-user-data (id)
  76   (check-type id fixnum)
  77   (with-mutex (*user-data-lock*)
  78     (multiple-value-bind (user-data p) (gethash id *user-data*)
  79       (values (car user-data) p))))
  80
  81 (defun user-data-exists-p (id)
  82   (nth-value 1 (find-user-data id)))
  83
  84 (defun update-user-data (id object)
  85   (check-type id fixnum)
  86   (with-mutex (*user-data-lock*)
  87     (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
  88       (cond
  89        ((not exists-p) (error "User data id ~A does not exist" id))
  90        (t
  91         (when (cdr user-data)
  92           (funcall (cdr user-data) (car user-data)))
  93         (setf (car user-data) object))))))
  94
  95 (defun destroy-user-data (id)
  96   (check-type id fixnum)
  97   (with-mutex (*user-data-lock*)
  98     (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
  99       (cond
 100 ;       ((not exists-p) (error "User data id ~A does not exist" id))
 101        (t
 102         (when (cdr user-data)
 103           (funcall (cdr user-data) (car user-data)))
 104         (remhash id *user-data*))))))
 105
 106 (defun take-user-data (id)
 107   (check-type id fixnum)
 108   (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
 109     (cond
 110       ((not exists-p) (error "User data id ~A does not exist" id))
 111       (t
 112         (when (cdr user-data)
 113           (funcall (cdr user-data) (car user-data)))
 114         (remhash id *user-data*)
 115         (car user-data)))))
 116
 117 (defmacro with-user-data ((var object) &body body)
 118   `(let ((,var (register-user-data ,object)))
 119      (unwind-protect
 120           ,@body
 121        (destroy-user-data ,var))))
 122
 123
 124 (deftype user-data-id () 'pointer-data)
 125
 126
 127 ;;;; Quarks
 128
 129 (deftype quark () 'unsigned)
 130
 131 (defbinding %quark-from-string () quark
 132   (string string))
 133
 134 (defun quark-intern (object)
 135   (etypecase object
 136     (quark object)
 137     (string (%quark-from-string object))
 138     (symbol (%quark-from-string (format nil "clg-~A:~A"
 139                                  (package-name (symbol-package object))
 140                                  object)))))
 141
 142 (defbinding quark-to-string () (static string)
 143   (quark quark))
 144
 145
 146 ;;;; Linked list (GList)
 147
 148 (deftype glist (type)
 149   `(or null (cons ,type list)))
 150
 151 (defbinding (%glist-prepend "g_list_prepend") () pointer
 152   (glist (or null pointer))
 153   (nil null))
 154
 155 (defbinding (%glist-reverse "g_list_reverse") () pointer
 156   (glist (or null pointer)))
 157
 158 (defun make-glist (element-type list &optional temp-p)
 159   (let ((writer (if (functionp element-type)
 160                     element-type
 161                   (writer-function element-type :temp temp-p))))
 162     (loop
 163      for element in list
 164      as glist = (%glist-prepend nil) then (%glist-prepend glist)
 165      do (funcall writer element glist)
 166      finally (return (%glist-reverse glist)))))
 167
 168 (defun glist-next (glist)
 169   (unless (null-pointer-p glist)
 170     (ref-pointer glist #.(size-of 'pointer))))
 171
 172 ;; Also used for gslists
 173 (defun map-glist (seqtype function glist element-type &optional (ref :read))
 174   (let ((reader (if (functionp element-type)
 175                     element-type
 176                   (reader-function element-type :ref ref))))
 177     (case seqtype
 178      ((nil)
 179       (loop
 180        as element = glist then (glist-next element)
 181        until (null-pointer-p element)
 182        do (funcall function (funcall reader element))))
 183      (list
 184       (loop
 185        as element = glist then (glist-next element)
 186        until (null-pointer-p element)
 187        collect (funcall function (funcall reader element))))
 188      (t
 189       (coerce
 190        (loop
 191         as element = glist then (glist-next element)
 192         until (null-pointer-p element)
 193         collect (funcall function (funcall reader element)))
 194        seqtype)))))
 195
 196 (defbinding (glist-free "g_list_free") () nil
 197   (glist pointer))
 198
 199 (defun destroy-glist (glist element-type &optional temp-p)
 200   (let ((destroy (if (functionp element-type)
 201                      element-type
 202                    (destroy-function element-type :temp temp-p))))
 203     (loop
 204      as element = glist then (glist-next element)
 205      until (null-pointer-p element)
 206      do (funcall destroy element)))
 207   (glist-free glist))
 208
 209 (define-type-method alien-type ((type glist))
 210   (declare (ignore type))
 211   (alien-type 'pointer))
 212
 213 (define-type-method argument-type ((type glist))
 214   'list)
 215
 216 (define-type-method return-type ((type glist))
 217   'list)
 218
 219 (define-type-method size-of ((type glist) &key inlined)
 220   (assert-not-inlined type inlined)
 221   (size-of 'pointer))
 222
 223 (define-type-method type-alignment ((type glist) &key inlined)
 224   (assert-not-inlined type inlined)
 225   (type-alignment 'pointer))
 226
 227 (define-type-method alien-arg-wrapper ((type glist) var list style form &optional copy-in-p)
 228   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
 229     (cond
 230       ((and (in-arg-p style) (not (out-arg-p style)))
 231        `(with-pointer (,var (make-glist ',element-type ,list ,(not copy-in-p)))
 232           (unwind-protect
 233               ,form
 234             ,(unless copy-in-p
 235                `(destroy-glist ,var ',element-type t)))))
 236       ((and (in-arg-p style) (out-arg-p style))
 237        (let ((glist (make-symbol "GLIST")))
 238          `(with-pointer (,glist (make-glist ',element-type ,list ,(not copy-in-p)))
 239             (with-pointer (,var ,glist)
 240               (unwind-protect
 241                   ,form
 242                 ,(unless copy-in-p
 243                    `(destroy-glist ,glist ',element-type t)))))))
 244       ((and (out-arg-p style) (not (in-arg-p style)))
 245        `(with-pointer (,var)
 246           ,form)))))
 247
 248 (define-type-method to-alien-form ((type glist) list &optional copy-p)
 249   (declare (ignore copy-p))
 250   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
 251     `(make-glist ',element-type ,list)))
 252
 253 (define-type-method to-alien-function ((type glist) &optional copy-p)
 254   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
 255     (values
 256      #'(lambda (list)
 257          (make-glist element-type list (not copy-p)))
 258      (unless copy-p
 259        #'(lambda (list glist)
 260            (declare (ignore list))
 261            (destroy-glist glist element-type t))))))
 262
 263 (define-type-method from-alien-form ((type glist) form &key (ref :free))
 264   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
 265     `(let ((glist ,form))
 266        (unwind-protect
 267            (map-glist 'list #'identity glist ',element-type
 268             ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
 269          ,(when (eq ref :free)
 270             `(destroy-glist glist ',element-type))))))
 271
 272 (define-type-method from-alien-function ((type glist) &key (ref :free))
 273   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
 274     (ecase ref
 275       (:free
 276        #'(lambda (glist)
 277            (prog1
 278                (map-glist 'list #'identity glist element-type :get)
 279              (glist-free glist))))
 280       (:copy
 281        #'(lambda (glist)
 282            (map-glist 'list #'identity glist element-type :read)))
 283       ((:static :temp)
 284        #'(lambda (glist)
 285            (map-glist 'list #'identity glist element-type :peek))))))
 286
 287 (define-type-method writer-function ((type glist) &key temp inlined)
 288   (assert-not-inlined type inlined)
 289   (let ((element-type (second (type-expand-to 'glist type))))
 290     #'(lambda (list location &optional (offset 0))
 291         (setf
 292          (ref-pointer location offset)
 293          (make-glist element-type list temp)))))
 294
 295 (define-type-method reader-function ((type glist) &key (ref :read) inlined)
 296   (assert-not-inlined type inlined)
 297   (let ((element-type (second (type-expand-to 'glist type))))
 298     (ecase ref
 299       ((:read :peek)
 300        #'(lambda (location &optional (offset 0))
 301            (unless (null-pointer-p (ref-pointer location offset))
 302              (map-glist 'list #'identity (ref-pointer location offset) element-type ref))))
 303       (:get
 304        #'(lambda (location &optional (offset 0))
 305            (unless (null-pointer-p (ref-pointer location offset))
 306              (prog1
 307                  (map-glist 'list #'identity (ref-pointer location offset) element-type :get)
 308                (glist-free (ref-pointer location offset))
 309                (setf (ref-pointer location offset) (make-pointer 0)))))))))
 310
 311 (define-type-method destroy-function ((type glist) &key temp inlined)
 312   (assert-not-inlined type inlined)
 313   (let ((element-type (second (type-expand-to 'glist type))))
 314     #'(lambda (location &optional (offset 0))
 315         (unless (null-pointer-p (ref-pointer location offset))
 316           (destroy-glist (ref-pointer location offset) element-type temp)
 317           (setf (ref-pointer location offset) (make-pointer 0))))))
 318
 319 (define-type-method copy-function ((type glist) &key inlined)
 320   (assert-not-inlined type inlined)
 321   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
 322     (let ((copy-element (copy-function element-type)))
 323       #'(lambda (from to &optional (offset 0))
 324           (unless (null-pointer-p (ref-pointer from offset))
 325             (loop
 326              as from-list = (ref-pointer from offset) then (glist-next from-list)
 327              as to-list = (%glist-prepend nil) then (%glist-prepend to-list)
 328              do (funcall copy-element from-list to-list)
 329              while (glist-next from-list)
 330              finally (setf (ref-pointer to offset) (%glist-reverse to-list))))))))
 331
 332
 333 ;;;; Single linked list (GSList)
 334
 335 (deftype gslist (type) `(or null (cons ,type list)))
 336
 337 (defbinding (%gslist-prepend "g_slist_prepend") () pointer
 338   (gslist pointer)
 339   (nil null))
 340
 341 (defbinding (%gslist-append "g_slist_append") () pointer
 342   (glist (or null pointer))
 343   (nil null))
 344
 345
 346 (defun make-gslist (element-type list &optional temp-p)
 347   (let ((writer (if (functionp element-type)
 348                     element-type
 349                   (writer-function element-type :temp temp-p))))
 350     (loop
 351      for element in (reverse list)
 352      as gslist = (%gslist-prepend (make-pointer 0)) then (%gslist-prepend gslist)
 353      do (funcall writer element gslist)
 354      finally (return gslist))))
 355
 356 (defbinding (gslist-free "g_slist_free") () nil
 357   (gslist pointer))
 358
 359 (defun destroy-gslist (gslist element-type &optional temp-p)
 360   (loop
 361    with destroy = (destroy-function element-type :temp temp-p)
 362    as element = gslist then (glist-next element)
 363    until (null-pointer-p element)
 364    do (funcall destroy element 0))
 365   (gslist-free gslist))
 366
 367 (define-type-method alien-type ((type gslist))
 368   (declare (ignore type))
 369   (alien-type 'pointer))
 370
 371 (define-type-method argument-type ((type gslist))
 372   'list)
 373
 374 (define-type-method return-type ((type gslist))
 375   'list)
 376
 377 (define-type-method size-of ((type gslist) &key inlined)
 378   (assert-not-inlined type inlined)
 379   (size-of 'pointer))
 380
 381 (define-type-method type-alignment ((type gslist) &key inlined)
 382   (assert-not-inlined type inlined)
 383   (type-alignment 'pointer))
 384
 385 (define-type-method alien-arg-wrapper ((type gslist) var list style form &optional copy-in-p)
 386   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
 387     (cond
 388       ((and (in-arg-p style) (not (out-arg-p style)))
 389        `(with-pointer (,var (make-gslist ',element-type ,list ,(not copy-in-p)))
 390           (unwind-protect
 391               ,form
 392             ,(unless copy-in-p
 393                `(destroy-gslist ,var ',element-type t)))))
 394       ((and (in-arg-p style) (out-arg-p style))
 395        (let ((gslist (make-symbol "GSLIST")))
 396          `(with-pointer (,gslist (make-gslist ',element-type ,list ,(not copy-in-p)))
 397             (with-pointer (,var ,gslist)
 398               (unwind-protect
 399                   ,form
 400                 ,(unless copy-in-p
 401                    `(destroy-gslist ,gslist ',element-type t)))))))
 402       ((and (out-arg-p style) (not (in-arg-p style)))
 403        `(with-pointer (,var)
 404           ,form)))))
 405
 406 (define-type-method to-alien-form ((type gslist) list &optional copy-p)
 407   (declare (ignore copy-p))
 408   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
 409     `(make-gslist ',element-type ,list)))
 410
 411 (define-type-method to-alien-function ((type gslist) &optional copy-p)
 412   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
 413     (values
 414      #'(lambda (list)
 415          (make-gslist element-type list (not copy-p)))
 416      (unless copy-p
 417        #'(lambda (list gslist)
 418            (declare (ignore list))
 419            (destroy-gslist gslist element-type t))))))
 420
 421 (define-type-method from-alien-form ((type gslist) form &key (ref :free))
 422   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
 423     `(let ((gslist ,form))
 424        (unwind-protect
 425            (map-glist 'list #'identity gslist ',element-type
 426             ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
 427          ,(when (eq ref :free)
 428             `(destroy-gslist gslist ',element-type))))))
 429
 430 (define-type-method from-alien-function ((type gslist)  &key (ref :free))
 431   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
 432     (ecase ref
 433       (:free
 434        #'(lambda (glist)
 435            (prog1
 436                (map-glist 'list #'identity glist element-type :get)
 437              (gslist-free glist))))
 438       (:copy
 439        #'(lambda (glist)
 440            (map-glist 'list #'identity glist element-type :read)))
 441       ((:static :temp)
 442        #'(lambda (glist)
 443            (map-glist 'list #'identity glist element-type :peek))))))
 444
 445 (define-type-method writer-function ((type gslist) &key temp inlined)
 446   (assert-not-inlined type inlined)
 447   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
 448     (let ((element-writer (writer-function element-type :temp temp)))
 449       #'(lambda (list location &optional (offset 0))
 450           (setf
 451            (ref-pointer location offset)
 452            (make-gslist element-writer list))))))
 453
 454 (define-type-method reader-function ((type gslist) &key (ref :read) inlined)
 455   (assert-not-inlined type inlined)
 456   (let ((element-type (second (type-expand-to 'gslist type))))
 457     (ecase ref
 458       ((:read :peek)
 459        #'(lambda (location &optional (offset 0))
 460            (unless (null-pointer-p (ref-pointer location offset))
 461              (map-glist 'list #'identity (ref-pointer location offset) element-type ref))))
 462       (:get
 463        #'(lambda (location &optional (offset 0))
 464            (unless (null-pointer-p (ref-pointer location offset))
 465              (prog1
 466                  (map-glist 'list #'identity (ref-pointer location offset) element-type :get)
 467                (gslist-free (ref-pointer location offset))
 468                (setf (ref-pointer location offset) (make-pointer 0)))))))))
 469
 470 (define-type-method destroy-function ((type gslist) &key temp inlined)
 471   (assert-not-inlined type inlined)
 472   (let ((element-type (second (type-expand-to 'gslist type))))
 473     #'(lambda (location &optional (offset 0))
 474         (unless (null-pointer-p (ref-pointer location offset))
 475           (destroy-gslist (ref-pointer location offset) element-type temp)
 476           (setf (ref-pointer location offset) (make-pointer 0))))))
 477
 478 (define-type-method copy-function ((type gslist) &key inlined)
 479   (assert-not-inlined type inlined)
 480   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
 481     (let ((copy-element (copy-function element-type)))
 482       #'(lambda (from to &optional (offset 0))
 483           (unless (null-pointer-p (ref-pointer from offset))
 484             (loop
 485              as from-list = (ref-pointer from offset)
 486                             then (glist-next from-list)
 487              as to-list = (setf (ref-pointer to offset) (%gslist-append nil))
 488                           then (%gslist-append to-list)
 489              do (funcall copy-element from-list to-list)
 490              while (glist-next from-list)))))))