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.45 2008-12-14 21:37:25 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 (deftype gssize () 'int)
  44 (deftype goffset () '(unsigned-int 64))
  45
  46
  47 (defbinding malloc0 () pointer
  48   (size gsize))
  49
  50 (defbinding free () nil
  51   (address pointer))
  52
  53 (setf *memory-allocator* #'malloc0)
  54 (setf *memory-deallocator* #'free)
  55
  56 (defbinding (reallocate-memory "g_realloc") () pointer
  57   (address pointer)
  58   (size gsize))
  59
  60 (defbinding (slice-alloc "g_slice_alloc0") () pointer
  61   (block-size gsize))
  62
  63 ;;;; User data is a mechanism to store references to lisp objects in
  64 ;;;; foreign code
  65
  66 ;; TODO: move to gffi
  67
  68 (defvar *user-data-lock* (make-mutex))
  69 (defvar *user-data* (make-hash-table))
  70 (defvar *user-data-next-id* 1)
  71
  72 (defun register-user-data (object &optional destroy-function)
  73   (check-type destroy-function (or null symbol function))
  74   (with-mutex (*user-data-lock*)
  75     (setf
  76      (gethash *user-data-next-id* *user-data*)
  77      (cons object destroy-function))
  78     (1- (incf *user-data-next-id*))))
  79
  80 (defun find-user-data (id)
  81   (check-type id fixnum)
  82   (with-mutex (*user-data-lock*)
  83     (multiple-value-bind (user-data p) (gethash id *user-data*)
  84       (values (car user-data) p))))
  85
  86 (defun user-data-exists-p (id)
  87   (nth-value 1 (find-user-data id)))
  88
  89 (defun update-user-data (id object)
  90   (check-type id fixnum)
  91   (with-mutex (*user-data-lock*)
  92     (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
  93       (cond
  94        ((not exists-p) (error "User data id ~A does not exist" id))
  95        (t
  96         (when (cdr user-data)
  97           (funcall (cdr user-data) (car user-data)))
  98         (setf (car user-data) object))))))
  99
 100 (defun destroy-user-data (id)
 101   (check-type id fixnum)
 102   (with-mutex (*user-data-lock*)
 103     (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
 104       (cond
 105 ;       ((not exists-p) (error "User data id ~A does not exist" id))
 106        (t
 107         (when (cdr user-data)
 108           (funcall (cdr user-data) (car user-data)))
 109         (remhash id *user-data*))))))
 110
 111 (defun take-user-data (id)
 112   (check-type id fixnum)
 113   (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
 114     (cond
 115       ((not exists-p) (error "User data id ~A does not exist" id))
 116       (t
 117         (when (cdr user-data)
 118           (funcall (cdr user-data) (car user-data)))
 119         (remhash id *user-data*)
 120         (car user-data)))))
 121
 122 (defmacro with-user-data ((var object) &body body)
 123   `(let ((,var (register-user-data ,object)))
 124      (unwind-protect
 125           ,@body
 126        (destroy-user-data ,var))))
 127
 128
 129 (deftype user-data-id () 'pointer-data)
 130
 131
 132 ;;;; Quarks
 133
 134 (deftype quark () 'unsigned)
 135
 136 (defbinding %quark-from-string () quark
 137   (string string))
 138
 139 (defun quark-intern (object)
 140   (etypecase object
 141     (quark object)
 142     (string (%quark-from-string object))
 143     (symbol (%quark-from-string (format nil "clg-~A:~A"
 144                                  (package-name (symbol-package object))
 145                                  object)))))
 146
 147 (defbinding quark-to-string () (static string)
 148   (quark quark))
 149
 150
 151 ;;;; Linked list (GList)
 152
 153 (deftype glist (type)
 154   `(or null (cons ,type list)))
 155
 156 (defbinding (%glist-prepend "g_list_prepend") () pointer
 157   (glist (or null pointer))
 158   (nil null))
 159
 160 (defbinding (%glist-reverse "g_list_reverse") () pointer
 161   (glist (or null pointer)))
 162
 163 (defun make-glist (element-type list &optional temp-p)
 164   (let ((writer (if (functionp element-type)
 165                     element-type
 166                   (writer-function element-type :temp temp-p))))
 167     (loop
 168      for element in list
 169      as glist = (%glist-prepend nil) then (%glist-prepend glist)
 170      do (funcall writer element glist)
 171      finally (return (%glist-reverse glist)))))
 172
 173 (defun glist-next (glist)
 174   (unless (null-pointer-p glist)
 175     (ref-pointer glist #.(size-of 'pointer))))
 176
 177 ;; Also used for gslists
 178 (defun map-glist (seqtype function glist element-type &optional (ref :read))
 179   (let ((reader (if (functionp element-type)
 180                     element-type
 181                   (reader-function element-type :ref ref))))
 182     (case seqtype
 183      ((nil)
 184       (loop
 185        as element = glist then (glist-next element)
 186        until (null-pointer-p element)
 187        do (funcall function (funcall reader element))))
 188      (list
 189       (loop
 190        as element = glist then (glist-next element)
 191        until (null-pointer-p element)
 192        collect (funcall function (funcall reader element))))
 193      (t
 194       (coerce
 195        (loop
 196         as element = glist then (glist-next element)
 197         until (null-pointer-p element)
 198         collect (funcall function (funcall reader element)))
 199        seqtype)))))
 200
 201 (defbinding (glist-free "g_list_free") () nil
 202   (glist pointer))
 203
 204 (defun destroy-glist (glist element-type &optional temp-p)
 205   (let ((destroy (if (functionp element-type)
 206                      element-type
 207                    (destroy-function element-type :temp temp-p))))
 208     (loop
 209      as element = glist then (glist-next element)
 210      until (null-pointer-p element)
 211      do (funcall destroy element)))
 212   (glist-free glist))
 213
 214 (define-type-method alien-type ((type glist))
 215   (declare (ignore type))
 216   (alien-type 'pointer))
 217
 218 (define-type-method argument-type ((type glist))
 219   'list)
 220
 221 (define-type-method return-type ((type glist))
 222   'list)
 223
 224 (define-type-method size-of ((type glist) &key inlined)
 225   (assert-not-inlined type inlined)
 226   (size-of 'pointer))
 227
 228 (define-type-method type-alignment ((type glist) &key inlined)
 229   (assert-not-inlined type inlined)
 230   (type-alignment 'pointer))
 231
 232 (define-type-method alien-arg-wrapper ((type glist) var list style form &optional copy-in-p)
 233   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
 234     (cond
 235       ((and (in-arg-p style) (not (out-arg-p style)))
 236        `(with-pointer (,var (make-glist ',element-type ,list ,(not copy-in-p)))
 237           (unwind-protect
 238               ,form
 239             ,(unless copy-in-p
 240                `(destroy-glist ,var ',element-type t)))))
 241       ((and (in-arg-p style) (out-arg-p style))
 242        (let ((glist (make-symbol "GLIST")))
 243          `(with-pointer (,glist (make-glist ',element-type ,list ,(not copy-in-p)))
 244             (with-pointer (,var ,glist)
 245               (unwind-protect
 246                   ,form
 247                 ,(unless copy-in-p
 248                    `(destroy-glist ,glist ',element-type t)))))))
 249       ((and (out-arg-p style) (not (in-arg-p style)))
 250        `(with-pointer (,var)
 251           ,form)))))
 252
 253 (define-type-method to-alien-form ((type glist) list &optional copy-p)
 254   (declare (ignore copy-p))
 255   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
 256     `(make-glist ',element-type ,list)))
 257
 258 (define-type-method to-alien-function ((type glist) &optional copy-p)
 259   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
 260     (values
 261      #'(lambda (list)
 262          (make-glist element-type list (not copy-p)))
 263      (unless copy-p
 264        #'(lambda (list glist)
 265            (declare (ignore list))
 266            (destroy-glist glist element-type t))))))
 267
 268 (define-type-method from-alien-form ((type glist) form &key (ref :free))
 269   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
 270     `(let ((glist ,form))
 271        (unwind-protect
 272            (map-glist 'list #'identity glist ',element-type
 273             ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
 274          ,(when (eq ref :free)
 275             `(destroy-glist glist ',element-type))))))
 276
 277 (define-type-method from-alien-function ((type glist) &key (ref :free))
 278   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
 279     (ecase ref
 280       (:free
 281        #'(lambda (glist)
 282            (prog1
 283                (map-glist 'list #'identity glist element-type :get)
 284              (glist-free glist))))
 285       (:copy
 286        #'(lambda (glist)
 287            (map-glist 'list #'identity glist element-type :read)))
 288       ((:static :temp)
 289        #'(lambda (glist)
 290            (map-glist 'list #'identity glist element-type :peek))))))
 291
 292 (define-type-method writer-function ((type glist) &key temp inlined)
 293   (assert-not-inlined type inlined)
 294   (let ((element-type (second (type-expand-to 'glist type))))
 295     #'(lambda (list location &optional (offset 0))
 296         (setf
 297          (ref-pointer location offset)
 298          (make-glist element-type list temp)))))
 299
 300 (define-type-method reader-function ((type glist) &key (ref :read) inlined)
 301   (assert-not-inlined type inlined)
 302   (let ((element-type (second (type-expand-to 'glist type))))
 303     (ecase ref
 304       ((:read :peek)
 305        #'(lambda (location &optional (offset 0))
 306            (unless (null-pointer-p (ref-pointer location offset))
 307              (map-glist 'list #'identity (ref-pointer location offset) element-type ref))))
 308       (:get
 309        #'(lambda (location &optional (offset 0))
 310            (unless (null-pointer-p (ref-pointer location offset))
 311              (prog1
 312                  (map-glist 'list #'identity (ref-pointer location offset) element-type :get)
 313                (glist-free (ref-pointer location offset))
 314                (setf (ref-pointer location offset) (make-pointer 0)))))))))
 315
 316 (define-type-method destroy-function ((type glist) &key temp inlined)
 317   (assert-not-inlined type inlined)
 318   (let ((element-type (second (type-expand-to 'glist type))))
 319     #'(lambda (location &optional (offset 0))
 320         (unless (null-pointer-p (ref-pointer location offset))
 321           (destroy-glist (ref-pointer location offset) element-type temp)
 322           (setf (ref-pointer location offset) (make-pointer 0))))))
 323
 324 (define-type-method copy-function ((type glist) &key inlined)
 325   (assert-not-inlined type inlined)
 326   (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
 327     (let ((copy-element (copy-function element-type)))
 328       #'(lambda (from to &optional (offset 0))
 329           (unless (null-pointer-p (ref-pointer from offset))
 330             (loop
 331              as from-list = (ref-pointer from offset) then (glist-next from-list)
 332              as to-list = (%glist-prepend nil) then (%glist-prepend to-list)
 333              do (funcall copy-element from-list to-list)
 334              while (glist-next from-list)
 335              finally (setf (ref-pointer to offset) (%glist-reverse to-list))))))))
 336
 337
 338 ;;;; Single linked list (GSList)
 339
 340 (deftype gslist (type) `(or null (cons ,type list)))
 341
 342 (defbinding (%gslist-prepend "g_slist_prepend") () pointer
 343   (gslist pointer)
 344   (nil null))
 345
 346 (defbinding (%gslist-append "g_slist_append") () pointer
 347   (glist (or null pointer))
 348   (nil null))
 349
 350
 351 (defun make-gslist (element-type list &optional temp-p)
 352   (let ((writer (if (functionp element-type)
 353                     element-type
 354                   (writer-function element-type :temp temp-p))))
 355     (loop
 356      for element in (reverse list)
 357      as gslist = (%gslist-prepend (make-pointer 0)) then (%gslist-prepend gslist)
 358      do (funcall writer element gslist)
 359      finally (return gslist))))
 360
 361 (defbinding (gslist-free "g_slist_free") () nil
 362   (gslist pointer))
 363
 364 (defun destroy-gslist (gslist element-type &optional temp-p)
 365   (loop
 366    with destroy = (destroy-function element-type :temp temp-p)
 367    as element = gslist then (glist-next element)
 368    until (null-pointer-p element)
 369    do (funcall destroy element 0))
 370   (gslist-free gslist))
 371
 372 (define-type-method alien-type ((type gslist))
 373   (declare (ignore type))
 374   (alien-type 'pointer))
 375
 376 (define-type-method argument-type ((type gslist))
 377   'list)
 378
 379 (define-type-method return-type ((type gslist))
 380   'list)
 381
 382 (define-type-method size-of ((type gslist) &key inlined)
 383   (assert-not-inlined type inlined)
 384   (size-of 'pointer))
 385
 386 (define-type-method type-alignment ((type gslist) &key inlined)
 387   (assert-not-inlined type inlined)
 388   (type-alignment 'pointer))
 389
 390 (define-type-method alien-arg-wrapper ((type gslist) var list style form &optional copy-in-p)
 391   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
 392     (cond
 393       ((and (in-arg-p style) (not (out-arg-p style)))
 394        `(with-pointer (,var (make-gslist ',element-type ,list ,(not copy-in-p)))
 395           (unwind-protect
 396               ,form
 397             ,(unless copy-in-p
 398                `(destroy-gslist ,var ',element-type t)))))
 399       ((and (in-arg-p style) (out-arg-p style))
 400        (let ((gslist (make-symbol "GSLIST")))
 401          `(with-pointer (,gslist (make-gslist ',element-type ,list ,(not copy-in-p)))
 402             (with-pointer (,var ,gslist)
 403               (unwind-protect
 404                   ,form
 405                 ,(unless copy-in-p
 406                    `(destroy-gslist ,gslist ',element-type t)))))))
 407       ((and (out-arg-p style) (not (in-arg-p style)))
 408        `(with-pointer (,var)
 409           ,form)))))
 410
 411 (define-type-method to-alien-form ((type gslist) list &optional copy-p)
 412   (declare (ignore copy-p))
 413   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
 414     `(make-gslist ',element-type ,list)))
 415
 416 (define-type-method to-alien-function ((type gslist) &optional copy-p)
 417   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
 418     (values
 419      #'(lambda (list)
 420          (make-gslist element-type list (not copy-p)))
 421      (unless copy-p
 422        #'(lambda (list gslist)
 423            (declare (ignore list))
 424            (destroy-gslist gslist element-type t))))))
 425
 426 (define-type-method from-alien-form ((type gslist) form &key (ref :free))
 427   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
 428     `(let ((gslist ,form))
 429        (unwind-protect
 430            (map-glist 'list #'identity gslist ',element-type
 431             ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
 432          ,(when (eq ref :free)
 433             `(destroy-gslist gslist ',element-type))))))
 434
 435 (define-type-method from-alien-function ((type gslist)  &key (ref :free))
 436   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
 437     (ecase ref
 438       (:free
 439        #'(lambda (glist)
 440            (prog1
 441                (map-glist 'list #'identity glist element-type :get)
 442              (gslist-free glist))))
 443       (:copy
 444        #'(lambda (glist)
 445            (map-glist 'list #'identity glist element-type :read)))
 446       ((:static :temp)
 447        #'(lambda (glist)
 448            (map-glist 'list #'identity glist element-type :peek))))))
 449
 450 (define-type-method writer-function ((type gslist) &key temp inlined)
 451   (assert-not-inlined type inlined)
 452   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
 453     (let ((element-writer (writer-function element-type :temp temp)))
 454       #'(lambda (list location &optional (offset 0))
 455           (setf
 456            (ref-pointer location offset)
 457            (make-gslist element-writer list))))))
 458
 459 (define-type-method reader-function ((type gslist) &key (ref :read) inlined)
 460   (assert-not-inlined type inlined)
 461   (let ((element-type (second (type-expand-to 'gslist type))))
 462     (ecase ref
 463       ((:read :peek)
 464        #'(lambda (location &optional (offset 0))
 465            (unless (null-pointer-p (ref-pointer location offset))
 466              (map-glist 'list #'identity (ref-pointer location offset) element-type ref))))
 467       (:get
 468        #'(lambda (location &optional (offset 0))
 469            (unless (null-pointer-p (ref-pointer location offset))
 470              (prog1
 471                  (map-glist 'list #'identity (ref-pointer location offset) element-type :get)
 472                (gslist-free (ref-pointer location offset))
 473                (setf (ref-pointer location offset) (make-pointer 0)))))))))
 474
 475 (define-type-method destroy-function ((type gslist) &key temp inlined)
 476   (assert-not-inlined type inlined)
 477   (let ((element-type (second (type-expand-to 'gslist type))))
 478     #'(lambda (location &optional (offset 0))
 479         (unless (null-pointer-p (ref-pointer location offset))
 480           (destroy-gslist (ref-pointer location offset) element-type temp)
 481           (setf (ref-pointer location offset) (make-pointer 0))))))
 482
 483 (define-type-method copy-function ((type gslist) &key inlined)
 484   (assert-not-inlined type inlined)
 485   (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
 486     (let ((copy-element (copy-function element-type)))
 487       #'(lambda (from to &optional (offset 0))
 488           (unless (null-pointer-p (ref-pointer from offset))
 489             (loop
 490              as from-list = (ref-pointer from offset)
 491                             then (glist-next from-list)
 492              as to-list = (setf (ref-pointer to offset) (%gslist-append nil))
 493                           then (%gslist-append to-list)
 494              do (funcall copy-element from-list to-list)
 495              while (glist-next from-list)))))))