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.17 2004-11-07 01:23:38 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 *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 destroy-user-data (id)
  68   (check-type id fixnum)
  69   (let ((user-data (gethash id *user-data*)))
  70     (when (cdr user-data)
  71       (funcall (cdr user-data) (car user-data))))
  72   (remhash id *user-data*))
  73
  74 (defmacro def-callback-marshal (name (return-type &rest args))
  75   (let ((names (loop
  76                 for arg in args
  77                 collect (if (atom arg) (gensym) (first arg))))
  78         (types (loop
  79                 for arg in args
  80                 collect (if (atom arg) arg (second arg)))))
  81     `(defcallback ,name (,return-type ,@(mapcar #'list names types)
  82                          (callback-id unsigned-int))
  83       (invoke-callback callback-id ',return-type ,@names))))
  84
  85
  86 ;;;; Quarks
  87
  88 (internal *quark-counter* *quark-from-object* *quark-to-object*)
  89
  90 (deftype quark () 'unsigned)
  91
  92 ;(defbinding %quark-get-reserved () quark)
  93
  94 (defbinding %quark-from-string () quark
  95   (string string))
  96
  97 (defvar *quark-counter* 0)
  98
  99 (defun %quark-get-reserved ()
 100   ;; The string is just a dummy
 101   (%quark-from-string (format nil "#@£$%&-quark-~D" (incf *quark-counter*))))
 102
 103 (defvar *quark-from-object* (make-hash-table))
 104 (defvar *quark-to-object* (make-hash-table))
 105
 106 (defun quark-from-object (object &key (test #'eq))
 107   (let ((hash-code (sxhash object)))
 108     (or
 109      (assoc-ref object (gethash hash-code *quark-from-object*) :test test)
 110      (let ((quark (%quark-get-reserved)))
 111        (setf
 112         (gethash hash-code *quark-from-object*)
 113         (append
 114          (gethash hash-code *quark-from-object*)
 115          (list (cons object quark))))
 116        (setf (gethash quark *quark-to-object*) object)
 117        quark))))
 118
 119 (defun quark-to-object (quark)
 120   (gethash quark *quark-to-object*))
 121
 122 (defun remove-quark (quark)
 123   (let* ((object (gethash quark *quark-to-object*))
 124          (hash-code (sxhash object)))
 125     (remhash quark *quark-to-object*)
 126     (unless (setf
 127              (gethash hash-code *quark-from-object*)
 128              (assoc-delete object (gethash hash-code *quark-from-object*)))
 129       (remhash hash-code *quark-from-object*))))
 130
 131
 132
 133 ;;;; Linked list (GList)
 134
 135 (deftype glist (type &key copy)
 136   (declare (ignore copy))
 137   `(or (null (cons ,type list))))
 138
 139 (defbinding (%glist-append-unsigned "g_list_append") () pointer
 140   (glist pointer)
 141   (data unsigned))
 142
 143 (defbinding (%glist-append-signed "g_list_append") () pointer
 144   (glist pointer)
 145   (data signed))
 146
 147 (defbinding (%glist-append-sap "g_list_append") () pointer
 148   (glist pointer)
 149   (data pointer))
 150
 151 (defun make-glist (type list)
 152   (let ((new-element (ecase (alien-type type)
 153                        (system-area-pointer #'%glist-append-sap)
 154                        ((signed-byte c-call:short c-call:int c-call:long)
 155                         #'%glist-append-signed)
 156                        ((unsigned-byte c-call:unsigned-short
 157                          c-call:unsigned-int c-call:unsigned-long)
 158                         #'%glist-append-unsigned)))
 159         (to-alien (to-alien-function type)))
 160     (loop
 161      for element in list
 162      as glist = (funcall new-element (or glist (make-pointer 0))
 163                  (funcall to-alien element))
 164      finally (return glist))))
 165
 166 (defun glist-next (glist)
 167   (unless (null-pointer-p glist)
 168     (sap-ref-sap glist +size-of-pointer+)))
 169
 170 ;; Also used for gslists
 171 (defun map-glist (seqtype function glist element-type)
 172   (let ((reader (reader-function element-type)))
 173     (case seqtype
 174      ((nil)
 175       (loop
 176        as tmp = glist then (glist-next tmp)
 177        until (null-pointer-p tmp)
 178        do (funcall function (funcall reader tmp))))
 179      (list
 180       (loop
 181        as tmp = glist then (glist-next tmp)
 182        until (null-pointer-p tmp)
 183        collect (funcall function (funcall reader tmp))))
 184      (t
 185       (coerce
 186        (loop
 187         as tmp = glist then (glist-next tmp)
 188         until (null-pointer-p tmp)
 189         collect (funcall function (funcall reader tmp)))
 190        seqtype)))))
 191
 192 (defbinding (glist-free "g_list_free") () nil
 193   (glist pointer))
 194
 195
 196 (defmethod alien-type ((type (eql 'glist)) &rest args)
 197   (declare (ignore type args))
 198   (alien-type 'pointer))
 199
 200 (defmethod size-of ((type (eql 'glist)) &rest args)
 201   (declare (ignore type args))
 202   (size-of 'pointer))
 203
 204 (defmethod to-alien-form (list (type (eql 'glist)) &rest args)
 205   (declare (ignore type))
 206   (destructuring-bind (element-type) args
 207     `(make-glist ',element-type ,list)))
 208
 209 (defmethod to-alien-function ((type (eql 'glist)) &rest args)
 210   (declare (ignore type))
 211   (destructuring-bind (element-type) args
 212     #'(lambda (list)
 213         (make-glist element-type list))))
 214
 215 (defmethod from-alien-form (glist (type (eql 'glist)) &rest args)
 216   (declare (ignore type))
 217   (destructuring-bind (element-type) args
 218     `(let ((glist ,glist))
 219       (unwind-protect
 220            (map-glist 'list #'identity glist ',element-type)
 221         (glist-free glist)))))
 222
 223 (defmethod from-alien-function ((type (eql 'glist)) &rest args)
 224   (declare (ignore type))
 225   (destructuring-bind (element-type) args
 226     #'(lambda (glist)
 227         (unwind-protect
 228              (map-glist 'list #'identity glist element-type)
 229           (glist-free glist)))))
 230
 231 (defmethod cleanup-form (glist (type (eql 'glist)) &rest args)
 232   (declare (ignore type args))
 233   `(glist-free ,glist))
 234
 235 (defmethod cleanup-function ((type (eql 'glist)) &rest args)
 236   (declare (ignore type args))
 237   #'glist-free)
 238
 239
 240
 241 ;;;; Single linked list (GSList)
 242
 243 (deftype gslist (type) `(or (null (cons ,type list))))
 244
 245 (defbinding (%gslist-prepend-unsigned "g_slist_prepend") () pointer
 246   (gslist pointer)
 247   (data unsigned))
 248
 249 (defbinding (%gslist-prepend-signed "g_slist_prepend") () pointer
 250   (gslist pointer)
 251   (data signed))
 252
 253 (defbinding (%gslist-prepend-sap "g_slist_prepend") () pointer
 254   (gslist pointer)
 255   (data pointer))
 256
 257 (defun make-gslist (type list)
 258   (let ((new-element (ecase (alien-type type)
 259                        (system-area-pointer #'%gslist-prepend-sap)
 260                        ((signed-byte c-call:short c-call:int c-call:long)
 261                         #'%gslist-prepend-signed)
 262                        ((unsigned-byte c-call:unsigned-short
 263                          c-call:unsigned-int c-call:unsigned-long)
 264                         #'%gslist-prepend-unsigned)))
 265         (to-alien (to-alien-function type)))
 266     (loop
 267      for element in (reverse list)
 268      as gslist = (funcall new-element (or gslist (make-pointer 0))
 269                   (funcall to-alien element))
 270      finally (return gslist))))
 271
 272 (defbinding (gslist-free "g_slist_free") () nil
 273   (gslist pointer))
 274
 275
 276 (defmethod alien-type ((type (eql 'gslist)) &rest args)
 277   (declare (ignore type args))
 278   (alien-type 'pointer))
 279
 280 (defmethod size-of ((type (eql 'gslist)) &rest args)
 281   (declare (ignore type args))
 282   (size-of 'pointer))
 283
 284 (defmethod to-alien-form (list (type (eql 'gslist)) &rest args)
 285   (declare (ignore type))
 286   (destructuring-bind (element-type) args
 287     `(make-sglist ',element-type ,list)))
 288
 289 (defmethod to-alien-function ((type (eql 'gslist)) &rest args)
 290   (declare (ignore type))
 291   (destructuring-bind (element-type) args
 292     #'(lambda (list)
 293         (make-gslist element-type list))))
 294
 295 (defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args)
 296   (declare (ignore type))
 297   (destructuring-bind (element-type) args
 298     `(let ((gslist ,gslist))
 299       (unwind-protect
 300            (map-glist 'list #'identity gslist ',element-type)
 301         (gslist-free gslist)))))
 302
 303 (defmethod from-alien-function ((type (eql 'gslist)) &rest args)
 304   (declare (ignore type))
 305   (destructuring-bind (element-type) args
 306     #'(lambda (gslist)
 307         (unwind-protect
 308              (map-glist 'list #'identity gslist element-type)
 309           (gslist-free gslist)))))
 310
 311 (defmethod cleanup-form (list (type (eql 'gslist)) &rest args)
 312   (declare (ignore type args))
 313   `(gslist-free ,list))
 314
 315 (defmethod cleanup-function ((type (eql 'gslist)) &rest args)
 316   (declare (ignore type args))
 317   #'gslist-free)
 318
 319
 320
 321 ;;; Vector
 322
 323 (defun make-c-vector (type length &optional content location)
 324   (let* ((size-of-type (size-of type))
 325          (location (or location (allocate-memory (* size-of-type length))))
 326          (writer (writer-function type)))
 327     (loop
 328      for element across content
 329      for i from 0 below length
 330      as offset = 0 then (+ offset size-of-type)
 331      do (funcall writer element location offset))
 332     location))
 333
 334
 335 (defun map-c-vector (seqtype function location element-type length)
 336   (let ((reader (reader-function element-type))
 337         (size-of-element (size-of element-type)))
 338     (case seqtype
 339      ((nil)
 340       (loop
 341        for i from 0 below length
 342        as offset = 0 then (+ offset size-of-element)
 343        do (funcall function (funcall reader location offset))))
 344      (list
 345       (loop
 346        for i from 0 below length
 347        as offset = 0 then (+ offset size-of-element)
 348        collect (funcall function (funcall reader location offset))))
 349      (t
 350       (loop
 351        with sequence = (make-sequence seqtype length)
 352        for i from 0 below length
 353        as offset = 0 then (+ offset size-of-element)
 354        do (setf
 355            (elt sequence i)
 356            (funcall function (funcall reader location offset)))
 357        finally (return sequence))))))
 358
 359
 360 (defmethod alien-type ((type (eql 'vector)) &rest args)
 361   (declare (ignore type args))
 362   (alien-type 'pointer))
 363
 364 (defmethod size-of ((type (eql 'vector)) &rest args)
 365   (declare (ignore type args))
 366   (size-of 'pointer))
 367
 368 (defmethod to-alien-form (vector (type (eql 'vector)) &rest args)
 369   (declare (ignore type))
 370   (destructuring-bind (element-type &optional (length '*)) args
 371     (if (eq length '*)
 372         `(let* ((vector ,vector)
 373                 (location (sap+
 374                            (allocate-memory (+ ,+size-of-int+
 375                                                (* ,(size-of element-type)
 376                                                   (length vector))))
 377                            ,+size-of-int+)))
 378           (make-c-vector ',element-type (length vector) vector location)
 379           (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector))
 380           location)
 381       `(make-c-vector ',element-type ,length ,vector))))
 382
 383 (defmethod from-alien-form (location (type (eql 'vector)) &rest args)
 384   (declare (ignore type))
 385   (destructuring-bind (element-type &optional (length '*)) args
 386     (if (eq length '*)
 387         (error "Can't use vector of variable size as return type")
 388       `(map-c-vector 'vector #'identity ',element-type ',length ,location))))
 389
 390 (defmethod cleanup-form (location (type (eql 'vector)) &rest args)
 391   (declare (ignore type))
 392   (destructuring-bind (element-type &optional (length '*)) args
 393     `(let* ((location ,location)
 394             (length ,(if (eq length '*)
 395                          `(sap-ref-32 location ,(- +size-of-int+))
 396                          length)))
 397       (loop
 398        with destroy = (destroy-function ',element-type)
 399        for i from 0 below length
 400        as offset = 0 then (+ offset ,(size-of element-type))
 401        do (funcall destroy location offset))
 402       (deallocate-memory ,(if (eq length '*)
 403                               `(sap+ location  ,(- +size-of-int+))
 404                             'location)))))