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.27 2005-02-14 00:44:26 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   (;#+cmu kernel:system-area-copy
  42    ;#+sbcl sb-impl::system-area-copy
  43    system-area-copy from 0 to 0 (* 8 length))
  44   to)
  45
  46
  47 ;;;; User data mechanism
  48
  49 (internal *user-data* *user-data-count*)
  50
  51 (defvar *user-data* (make-hash-table))
  52 (defvar *user-data-count* 0)
  53
  54 (defun register-user-data (object &optional destroy-function)
  55   (check-type destroy-function (or null symbol function))
  56   (incf *user-data-count*)
  57   (setf
  58    (gethash *user-data-count* *user-data*)
  59    (cons object destroy-function))
  60   *user-data-count*)
  61
  62 (defun find-user-data (id)
  63   (check-type id fixnum)
  64   (multiple-value-bind (user-data p) (gethash id *user-data*)
  65     (values (car user-data) p)))
  66
  67 (defun user-data-exists-p (id)
  68   (nth-value 1 (find-user-data id)))
  69
  70 (defun update-user-data (id object)
  71   (check-type id fixnum)
  72   (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
  73     (cond
  74      ((not exists-p) (error "User data id ~A does not exist" id))
  75      (t
  76       (when (cdr user-data)
  77         (funcall (cdr user-data) (car user-data)))
  78       (setf (car user-data) object)))))
  79
  80 (defun destroy-user-data (id)
  81   (check-type id fixnum)
  82   (let ((user-data (gethash id *user-data*)))
  83     (when (cdr user-data)
  84       (funcall (cdr user-data) (car user-data))))
  85   (remhash id *user-data*))
  86
  87
  88 ;;;; Quarks
  89
  90 (deftype quark () 'unsigned)
  91
  92 (defbinding %quark-from-string () quark
  93   (string string))
  94
  95 (defun quark-intern (object)
  96   (etypecase object
  97     (quark object)
  98     (string (%quark-from-string object))
  99     (symbol (%quark-from-string (format nil "clg-~A:~A"
 100                                  (package-name (symbol-package object))
 101                                  object)))))
 102
 103 (defbinding quark-to-string () (copy-of string)
 104   (quark quark))
 105
 106
 107 ;;;; Linked list (GList)
 108
 109 (deftype glist (type)
 110   `(or (null (cons ,type list))))
 111
 112 (defbinding (%glist-append "g_list_append") () pointer
 113   (glist pointer)
 114   (nil null))
 115
 116 (defun make-glist (type list)
 117   (loop
 118    with writer = (writer-function type)
 119    for element in list
 120    as glist = (%glist-append (or glist (make-pointer 0)))
 121    do (funcall writer element glist)
 122    finally (return glist)))
 123
 124 (defun glist-next (glist)
 125   (unless (null-pointer-p glist)
 126     (sap-ref-sap glist +size-of-pointer+)))
 127
 128 ;; Also used for gslists
 129 (defun map-glist (seqtype function glist element-type)
 130   (let ((reader (reader-function element-type)))
 131     (case seqtype
 132      ((nil)
 133       (loop
 134        as tmp = glist then (glist-next tmp)
 135        until (null-pointer-p tmp)
 136        do (funcall function (funcall reader tmp))))
 137      (list
 138       (loop
 139        as tmp = glist then (glist-next tmp)
 140        until (null-pointer-p tmp)
 141        collect (funcall function (funcall reader tmp))))
 142      (t
 143       (coerce
 144        (loop
 145         as tmp = glist then (glist-next tmp)
 146         until (null-pointer-p tmp)
 147         collect (funcall function (funcall reader tmp)))
 148        seqtype)))))
 149
 150 (defbinding (glist-free "g_list_free") () nil
 151   (glist pointer))
 152
 153 (defun destroy-glist (glist element-type)
 154   (loop
 155    with destroy = (destroy-function element-type)
 156    as tmp = glist then (glist-next tmp)
 157    until (null-pointer-p tmp)
 158    do (funcall destroy tmp 0))
 159   (glist-free glist))
 160
 161 (defmethod alien-type ((type (eql 'glist)) &rest args)
 162   (declare (ignore type args))
 163   (alien-type 'pointer))
 164
 165 (defmethod size-of ((type (eql 'glist)) &rest args)
 166   (declare (ignore type args))
 167   (size-of 'pointer))
 168
 169 (defmethod to-alien-form (list (type (eql 'glist)) &rest args)
 170   (declare (ignore type))
 171   (destructuring-bind (element-type) args
 172     `(make-glist ',element-type ,list)))
 173
 174 (defmethod to-alien-function ((type (eql 'glist)) &rest args)
 175   (declare (ignore type))
 176   (destructuring-bind (element-type) args
 177     #'(lambda (list)
 178         (make-glist element-type list))))
 179
 180 (defmethod from-alien-form (glist (type (eql 'glist)) &rest args)
 181   (declare (ignore type))
 182   (destructuring-bind (element-type) args
 183     `(let ((glist ,glist))
 184       (unwind-protect
 185            (map-glist 'list #'identity glist ',element-type)
 186         (destroy-glist glist ',element-type)))))
 187
 188 (defmethod from-alien-function ((type (eql 'glist)) &rest args)
 189   (declare (ignore type))
 190   (destructuring-bind (element-type) args
 191     #'(lambda (glist)
 192         (unwind-protect
 193              (map-glist 'list #'identity glist element-type)
 194           (destroy-glist glist element-type)))))
 195
 196 (defmethod copy-from-alien-form (glist (type (eql 'glist)) &rest args)
 197   (declare (ignore type))
 198   (destructuring-bind (element-type) args
 199     `(map-glist 'list #'identity ,glist ',element-type)))
 200
 201 (defmethod copy-from-alien-function ((type (eql 'glist)) &rest args)
 202   (declare (ignore type))
 203   (destructuring-bind (element-type) args
 204     #'(lambda (glist)
 205         (map-glist 'list #'identity glist element-type))))
 206
 207 (defmethod cleanup-form (glist (type (eql 'glist)) &rest args)
 208   (declare (ignore type))
 209   (destructuring-bind (element-type) args
 210     `(destroy-glist ,glist ',element-type)))
 211
 212 (defmethod cleanup-function ((type (eql 'glist)) &rest args)
 213   (declare (ignore type))
 214   (destructuring-bind (element-type) args
 215     #'(lambda (glist)
 216         (destroy-glist glist element-type))))
 217
 218 (defmethod writer-function ((type (eql 'glist)) &rest args)
 219   (declare (ignore type))
 220   (destructuring-bind (element-type) args
 221     #'(lambda (list location &optional (offset 0))
 222         (setf
 223          (sap-ref-sap location offset)
 224          (make-glist element-type list)))))
 225
 226 (defmethod reader-function ((type (eql 'glist)) &rest args)
 227   (declare (ignore type))
 228   (destructuring-bind (element-type) args
 229     #'(lambda (location &optional (offset 0))
 230         (unless (null-pointer-p (sap-ref-sap location offset))
 231           (map-glist 'list #'identity (sap-ref-sap location offset) element-type)))))
 232
 233 (defmethod destroy-function ((type (eql 'glist)) &rest args)
 234   (declare (ignore type))
 235   (destructuring-bind (element-type) args
 236     #'(lambda (location &optional (offset 0))
 237         (unless (null-pointer-p (sap-ref-sap location offset))
 238           (destroy-glist (sap-ref-sap location offset) element-type)
 239           (setf (sap-ref-sap location offset) (make-pointer 0))))))
 240
 241
 242
 243 ;;;; Single linked list (GSList)
 244
 245 (deftype gslist (type) `(or (null (cons ,type list))))
 246
 247 (defbinding (%gslist-prepend "g_slist_prepend") () pointer
 248   (gslist pointer)
 249   (nil null))
 250
 251 (defun make-gslist (type list)
 252   (loop
 253    with writer = (writer-function type)
 254    for element in (reverse list)
 255    as gslist = (%gslist-prepend (or gslist (make-pointer 0)))
 256    do (funcall writer element gslist)
 257    finally (return gslist)))
 258
 259 (defbinding (gslist-free "g_slist_free") () nil
 260   (gslist pointer))
 261
 262 (defun destroy-gslist (gslist element-type)
 263   (loop
 264    with destroy = (destroy-function element-type)
 265    as tmp = gslist then (glist-next tmp)
 266    until (null-pointer-p tmp)
 267    do (funcall destroy tmp 0))
 268   (gslist-free gslist))
 269
 270 (defmethod alien-type ((type (eql 'gslist)) &rest args)
 271   (declare (ignore type args))
 272   (alien-type 'pointer))
 273
 274 (defmethod size-of ((type (eql 'gslist)) &rest args)
 275   (declare (ignore type args))
 276   (size-of 'pointer))
 277
 278 (defmethod to-alien-form (list (type (eql 'gslist)) &rest args)
 279   (declare (ignore type))
 280   (destructuring-bind (element-type) args
 281     `(make-sglist ',element-type ,list)))
 282
 283 (defmethod to-alien-function ((type (eql 'gslist)) &rest args)
 284   (declare (ignore type))
 285   (destructuring-bind (element-type) args
 286     #'(lambda (list)
 287         (make-gslist element-type list))))
 288
 289 (defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args)
 290   (declare (ignore type))
 291   (destructuring-bind (element-type) args
 292     `(let ((gslist ,gslist))
 293       (unwind-protect
 294            (map-glist 'list #'identity gslist ',element-type)
 295         (destroy-gslist gslist ',element-type)))))
 296
 297 (defmethod from-alien-function ((type (eql 'gslist)) &rest args)
 298   (declare (ignore type))
 299   (destructuring-bind (element-type) args
 300     #'(lambda (gslist)
 301         (unwind-protect
 302              (map-glist 'list #'identity gslist element-type)
 303           (destroy-gslist gslist element-type)))))
 304
 305 (defmethod copy-from-alien-form (gslist (type (eql 'gslist)) &rest args)
 306   (declare (ignore type))
 307   (destructuring-bind (element-type) args
 308     `(map-glist 'list #'identity ,gslist ',element-type)))
 309
 310 (defmethod copy-from-alien-function ((type (eql 'gslist)) &rest args)
 311   (declare (ignore type))
 312   (destructuring-bind (element-type) args
 313     #'(lambda (gslist)
 314         (map-glist 'list #'identity gslist element-type))))
 315
 316 (defmethod cleanup-form (gslist (type (eql 'gslist)) &rest args)
 317   (declare (ignore type))
 318   (destructuring-bind (element-type) args
 319     `(destroy-gslist ,gslist ',element-type)))
 320
 321 (defmethod cleanup-function ((type (eql 'gslist)) &rest args)
 322   (declare (ignore type))
 323   (destructuring-bind (element-type) args
 324     #'(lambda (gslist)
 325         (destroy-gslist gslist element-type))))
 326
 327 (defmethod writer-function ((type (eql 'gslist)) &rest args)
 328   (declare (ignore type))
 329   (destructuring-bind (element-type) args
 330     #'(lambda (list location &optional (offset 0))
 331         (setf
 332          (sap-ref-sap location offset)
 333          (make-gslist element-type list)))))
 334
 335 (defmethod reader-function ((type (eql 'gslist)) &rest args)
 336   (declare (ignore type))
 337   (destructuring-bind (element-type) args
 338     #'(lambda (location &optional (offset 0))
 339         (unless (null-pointer-p (sap-ref-sap location offset))
 340           (map-glist 'list #'identity (sap-ref-sap location offset) element-type)))))
 341
 342 (defmethod destroy-function ((type (eql 'gslist)) &rest args)
 343   (declare (ignore type))
 344   (destructuring-bind (element-type) args
 345     #'(lambda (location &optional (offset 0))
 346         (unless (null-pointer-p (sap-ref-sap location offset))
 347           (destroy-gslist (sap-ref-sap location offset) element-type)
 348           (setf (sap-ref-sap location offset) (make-pointer 0))))))
 349
 350
 351 ;;; Vector
 352
 353 (defun make-c-vector (type length &optional content location)
 354   (let* ((size-of-type (size-of type))
 355          (location (or location (allocate-memory (* size-of-type length))))
 356          (writer (writer-function type)))
 357     (etypecase content
 358       (vector
 359        (loop
 360         for element across content
 361         for i from 0 below length
 362         as offset = 0 then (+ offset size-of-type)
 363         do (funcall writer element location offset)))
 364       (list
 365        (loop
 366         for element in content
 367         for i from 0 below length
 368         as offset = 0 then (+ offset size-of-type)
 369         do (funcall writer element location offset))))
 370     location))
 371
 372
 373 (defun map-c-vector (seqtype function location element-type length)
 374   (let ((reader (reader-function element-type))
 375         (size-of-element (size-of element-type)))
 376     (case seqtype
 377      ((nil)
 378       (loop
 379        for i from 0 below length
 380        as offset = 0 then (+ offset size-of-element)
 381        do (funcall function (funcall reader location offset))))
 382      (list
 383       (loop
 384        for i from 0 below length
 385        as offset = 0 then (+ offset size-of-element)
 386        collect (funcall function (funcall reader location offset))))
 387      (t
 388       (loop
 389        with sequence = (make-sequence seqtype length)
 390        for i from 0 below length
 391        as offset = 0 then (+ offset size-of-element)
 392        do (setf
 393            (elt sequence i)
 394            (funcall function (funcall reader location offset)))
 395        finally (return sequence))))))
 396
 397
 398 (defun destroy-c-vector (location element-type length)
 399   (loop
 400    with destroy = (destroy-function element-type)
 401    with element-size = (size-of element-type)
 402    for i from 0 below length
 403    as offset = 0 then (+ offset element-size)
 404    do (funcall destroy location offset))
 405   (deallocate-memory location))
 406
 407
 408 (defmethod alien-type ((type (eql 'vector)) &rest args)
 409   (declare (ignore type args))
 410   (alien-type 'pointer))
 411
 412 (defmethod size-of ((type (eql 'vector)) &rest args)
 413   (declare (ignore type args))
 414   (size-of 'pointer))
 415
 416 (defmethod to-alien-form (vector (type (eql 'vector)) &rest args)
 417   (declare (ignore type))
 418   (destructuring-bind (element-type &optional (length '*)) args
 419     (if (eq length '*)
 420         `(let* ((vector ,vector)
 421                 (location (sap+
 422                            (allocate-memory (+ ,+size-of-int+
 423                                                (* ,(size-of element-type)
 424                                                   (length vector))))
 425                            ,+size-of-int+)))
 426           (make-c-vector ',element-type (length vector) vector location)
 427           (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector))
 428           location)
 429       `(make-c-vector ',element-type ,length ,vector))))
 430
 431 (defmethod from-alien-form (c-vector (type (eql 'vector)) &rest args)
 432   (declare (ignore type))
 433   (destructuring-bind (element-type &optional (length '*)) args
 434     (if (eq length '*)
 435         (error "Can't use vector of variable size as return type")
 436       `(let ((c-vector ,c-vector))
 437         (prog1
 438             (map-c-vector 'vector #'identity c-vector ',element-type ,length)
 439           (destroy-c-vector c-vector ',element-type ,length))))))
 440
 441 (defmethod copy-from-alien-form (c-vector (type (eql 'vector)) &rest args)
 442   (declare (ignore type))
 443   (destructuring-bind (element-type &optional (length '*)) args
 444     (if (eq length '*)
 445         (error "Can't use vector of variable size as return type")
 446       `(map-c-vector 'vector #'identity ,c-vector ',element-type ',length))))
 447
 448 (defmethod cleanup-form (location (type (eql 'vector)) &rest args)
 449   (declare (ignore type))
 450   (destructuring-bind (element-type &optional (length '*)) args
 451     `(let* ((location ,location)
 452             (length ,(if (eq length '*)
 453                          `(sap-ref-32 location ,(- +size-of-int+))
 454                          length)))
 455       (loop
 456        with destroy = (destroy-function ',element-type)
 457        for i from 0 below length
 458        as offset = 0 then (+ offset ,(size-of element-type))
 459        do (funcall destroy location offset))
 460       (deallocate-memory ,(if (eq length '*)
 461                               `(sap+ location  ,(- +size-of-int+))
 462                             'location)))))
 463
 464 (defmethod writer-function ((type (eql 'vector)) &rest args)
 465   (declare (ignore type))
 466   (destructuring-bind (element-type &optional (length '*)) args
 467     #'(lambda (vector location &optional (offset 0))
 468         (setf
 469          (sap-ref-sap location offset)
 470          (make-c-vector element-type length vector)))))
 471
 472 (defmethod reader-function ((type (eql 'vector)) &rest args)
 473   (declare (ignore type))
 474   (destructuring-bind (element-type &optional (length '*)) args
 475     (if (eq length '*)
 476         (error "Can't create reader function for vector of variable size")
 477       #'(lambda (location &optional (offset 0))
 478           (unless (null-pointer-p (sap-ref-sap location offset))
 479             (map-c-vector 'vector #'identity (sap-ref-sap location offset)
 480              element-type length))))))
 481
 482 (defmethod destroy-function ((type (eql 'vector)) &rest args)
 483   (declare (ignore type))
 484   (destructuring-bind (element-type &optional (length '*)) args
 485     (if (eq length '*)
 486         (error "Can't create destroy function for vector of variable size")
 487       #'(lambda (location &optional (offset 0))
 488           (unless (null-pointer-p (sap-ref-sap location offset))
 489             (destroy-c-vector
 490              (sap-ref-sap location offset) element-type length)
 491             (setf (sap-ref-sap location offset) (make-pointer 0)))))))
 492
 493
 494 ;;;; Null terminated vector
 495
 496 (defun make-0-vector (type content &optional location)
 497   (let* ((size-of-type (size-of type))
 498          (location (or
 499                     location
 500                     (allocate-memory (* size-of-type (1+ (length content))))))
 501          (writer (writer-function type)))
 502     (etypecase content
 503       (vector
 504        (loop
 505         for element across content
 506         as offset = 0 then (+ offset size-of-type)
 507         do (funcall writer element location offset)
 508         finally (setf (sap-ref-sap location offset) (make-pointer 0))))
 509       (list
 510        (loop
 511         for element in content
 512         as offset = 0 then (+ offset size-of-type)
 513         do (funcall writer element location offset)
 514         finally (setf (sap-ref-sap location (+ offset size-of-type)) (make-pointer 0)))))
 515     location))
 516
 517
 518 (defun map-0-vector (seqtype function location element-type)
 519   (let ((reader (reader-function element-type))
 520         (size-of-element (size-of element-type)))
 521     (case seqtype
 522      ((nil)
 523       (loop
 524        as offset = 0 then (+ offset size-of-element)
 525        until (null-pointer-p (sap-ref-sap location offset))
 526        do (funcall function (funcall reader location offset))))
 527      (list
 528       (loop
 529        as offset = 0 then (+ offset size-of-element)
 530        until (null-pointer-p (sap-ref-sap location offset))
 531        collect (funcall function (funcall reader location offset))))
 532      (t
 533       (coerce
 534        (loop
 535         as offset = 0 then (+ offset size-of-element)
 536         until (null-pointer-p (sap-ref-sap location offset))
 537         collect (funcall function (funcall reader location offset)))
 538        seqtype)))))
 539
 540
 541 (defun destroy-0-vector (location element-type)
 542   (loop
 543    with destroy = (destroy-function element-type)
 544    with element-size = (size-of element-type)
 545    as offset = 0 then (+ offset element-size)
 546    until (null-pointer-p (sap-ref-sap location offset))
 547    do (funcall destroy location offset))
 548   (deallocate-memory location))
 549
 550
 551 (defmethod alien-type ((type (eql 'null-terminated-vector)) &rest args)
 552   (declare (ignore type args))
 553   (alien-type 'pointer))
 554
 555 (defmethod size-of ((type (eql 'null-terminated-vector)) &rest args)
 556   (declare (ignore type args))
 557   (alien-type 'pointer))
 558
 559 (defmethod writer-function ((type (eql 'null-terminated-vector)) &rest args)
 560   (declare (ignore type))
 561   (destructuring-bind (element-type) args
 562     (unless (eq (alien-type element-type) (alien-type 'pointer))
 563       (error "Elements in null-terminated vectors need to be of pointer types"))
 564     #'(lambda (vector location &optional (offset 0))
 565         (setf
 566          (sap-ref-sap location offset)
 567          (make-0-vector element-type vector)))))
 568
 569 (defmethod reader-function ((type (eql 'null-terminated-vector)) &rest args)
 570   (declare (ignore type))
 571   (destructuring-bind (element-type) args
 572     (unless (eq (alien-type element-type) (alien-type 'pointer))
 573       (error "Elements in null-terminated vectors need to be of pointer types"))
 574     #'(lambda (location &optional (offset 0))
 575         (unless (null-pointer-p (sap-ref-sap location offset))
 576           (map-0-vector 'vector #'identity (sap-ref-sap location offset)
 577            element-type)))))
 578
 579 (defmethod destroy-function ((type (eql 'null-terminated-vector)) &rest args)
 580   (declare (ignore type))
 581   (destructuring-bind (element-type) args
 582     (unless (eq (alien-type element-type) (alien-type 'pointer))
 583       (error "Elements in null-terminated vectors need to be of pointer types"))
 584     #'(lambda (location &optional (offset 0))
 585           (unless (null-pointer-p (sap-ref-sap location offset))
 586             (destroy-0-vector
 587              (sap-ref-sap location offset) element-type)
 588             (setf (sap-ref-sap location offset) (make-pointer 0))))))
 589
 590 (defmethod unbound-value ((type (eql 'null-terminated-vector)) &rest args)
 591   (declare (ignore type args))
 592   (values t nil))