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.7 2000-10-05 17:17:41 espen Exp $
  19
  20
  21 (in-package "GLIB")
  22 (use-prefix "g")
  23
  24
  25 ;;;; Memory management
  26
  27 (define-foreign ("g_malloc0" allocate-memory) () pointer
  28   (size unsigned-long))
  29
  30 (define-foreign ("g_realloc" reallocate-memory) () pointer
  31   (address pointer)
  32   (size unsigned-long))
  33
  34 (define-foreign ("g_free" deallocate-memory) () nil
  35   (address pointer))
  36
  37 (defun copy-memory (from length &optional (to (allocate-memory length)))
  38   (kernel:system-area-copy from 0 to 0 (* 8 length))
  39   to)
  40
  41
  42
  43 ;;;; Quarks
  44
  45 (deftype quark () 'unsigned)
  46
  47 ;(define-foreign %quark-get-reserved () quark)
  48
  49 (define-foreign %quark-from-string () quark
  50   (string string))
  51
  52 (defvar *string-counter* 0)
  53
  54 (defun %quark-get-reserved ()
  55   (%quark-from-string (format nil "CLG-~D" (incf *string-counter*))))
  56
  57 (defvar *quark-from-object* (make-hash-table))
  58 (defvar *quark-to-object* (make-hash-table))
  59
  60 (defun quark-from-object (object &key (test #'eq))
  61   (let ((hash-code (sxhash object)))
  62     (or
  63      (assoc-ref object (gethash hash-code *quark-from-object*) :test test)
  64      (let ((quark (%quark-get-reserved)))
  65        (setf
  66         (gethash hash-code *quark-from-object*)
  67         (append
  68          (gethash hash-code *quark-from-object*)
  69          (list (cons object quark))))
  70        (setf (gethash quark *quark-to-object*) object)
  71        quark))))
  72
  73 (defun quark-to-object (quark)
  74   (gethash quark *quark-to-object*))
  75
  76 (defun remove-quark (quark)
  77   (let* ((object (gethash quark *quark-to-object*))
  78          (hash-code (sxhash object)))
  79     (remhash quark *quark-to-object*)
  80     (unless (setf
  81              (gethash hash-code *quark-from-object*)
  82              (assoc-delete object (gethash hash-code *quark-from-object*)))
  83       (remhash hash-code *quark-from-object*))))
  84
  85
  86
  87 ;;;; Linked list (GList)
  88
  89 (deftype glist (type) `(or (null (cons ,type list))))
  90
  91 (define-foreign ("g_list_append" %glist-append-unsigned) () pointer
  92   (glist pointer)
  93   (data unsigned))
  94
  95 (define-foreign ("g_list_append" %glist-append-signed) () pointer
  96   (glist pointer)
  97   (data signed))
  98
  99 (define-foreign ("g_list_append" %glist-append-sap) () pointer
 100   (glist pointer)
 101   (data pointer))
 102
 103 (defmacro glist-append (glist value type-spec)
 104   (ecase (first (mklist (translate-type-spec type-spec)))
 105     (unsigned `(%glist-append-unsigned ,glist ,value))
 106     (signed `(%glist-append-signed ,glist ,value))
 107     (system-area-pointer `(%glist-append-sap ,glist ,value))))
 108
 109 (defmacro glist-data (glist type-spec)
 110   (ecase (first (mklist (translate-type-spec type-spec)))
 111     (unsigned `(sap-ref-unsigned ,glist 0))
 112     (signed `(sap-ref-signed ,glist 0))
 113     (system-area-pointer `(sap-ref-sap ,glist 0))))
 114
 115 (defun glist-next (glist)
 116   (unless (null-pointer-p glist)
 117     (sap-ref-sap glist +size-of-sap+)))
 118
 119 (define-foreign ("g_list_free" glist-free) () nil
 120   (glist pointer))
 121
 122 (deftype-method translate-type-spec glist (type-spec)
 123   (declare (ignore type-spec))
 124   (translate-type-spec 'pointer))
 125
 126 (deftype-method size-of glist (type-spec)
 127   (declare (ignore type-spec))
 128   (size-of 'pointer))
 129
 130 (deftype-method translate-to-alien glist (type-spec list &optional copy)
 131   (declare (ignore copy))
 132   (let* ((element-type-spec (second (type-expand-to 'glist type-spec)))
 133          (to-alien (translate-to-alien element-type-spec 'element t)))
 134     `(let ((glist (make-pointer 0)))
 135        (dolist (element ,list glist)
 136          (setq glist (glist-append glist ,to-alien ,element-type-spec))))))
 137
 138 (deftype-method translate-from-alien
 139     glist (type-spec glist &optional (alloc :reference))
 140   (let ((element-type-spec (second (type-expand-to 'glist type-spec))))
 141     `(let ((glist ,glist)
 142            (list nil))
 143        (do ((tmp glist (glist-next tmp)))
 144            ((null-pointer-p tmp))
 145          (push
 146           ,(translate-from-alien
 147             element-type-spec `(glist-data tmp ,element-type-spec) alloc)
 148           list))
 149        ,(when (eq alloc :reference)
 150           '(glist-free glist))
 151        (nreverse list))))
 152
 153 (deftype-method cleanup-alien glist (type-spec glist &optional copied)
 154   (declare (ignore copied))
 155   (let* ((element-type-spec (second (type-expand-to 'glist type-spec)))
 156          (alien-type-spec (translate-type-spec element-type-spec)))
 157     `(let ((glist ,glist))
 158        (unless (null-pointer-p glist)
 159          ,(when (eq alien-type-spec 'system-area-pointer)
 160             `(do ((tmp glist (glist-next tmp)))
 161                  ((null-pointer-p tmp))
 162                ,(cleanup-alien
 163                  element-type-spec `(glist-data tmp ,element-type-spec) t)))
 164          (glist-free glist)))))
 165
 166
 167
 168 ;;;; Single linked list (GSList)
 169
 170 (deftype gslist (type) `(or (null (cons ,type list))))
 171
 172 (define-foreign ("g_slist_prepend" %gslist-prepend-unsigned) () pointer
 173   (gslist pointer)
 174   (data unsigned))
 175
 176 (define-foreign ("g_slist_prepend" %gslist-prepend-signed) () pointer
 177   (gslist pointer)
 178   (data signed))
 179
 180 (define-foreign ("g_slist_prepend" %gslist-prepend-sap) () pointer
 181   (gslist pointer)
 182   (data pointer))
 183
 184 (defmacro gslist-prepend (gslist value type-spec)
 185   (ecase (first (mklist (translate-type-spec type-spec)))
 186     (unsigned `(%gslist-prepend-unsigned ,gslist ,value))
 187     (signed `(%gslist-prepend-signed ,gslist ,value))
 188     (system-area-pointer `(%gslist-prepend-sap ,gslist ,value))))
 189
 190 (define-foreign ("g_slist_free" gslist-free) () nil
 191   (gslist pointer))
 192
 193 (deftype-method translate-type-spec gslist (type-spec)
 194   (declare (ignore type-spec))
 195   (translate-type-spec 'pointer))
 196
 197 (deftype-method size-of gslist (type-spec)
 198   (declare (ignore type-spec))
 199   (size-of 'pointer))
 200
 201 (deftype-method translate-to-alien gslist (type-spec list &optional copy)
 202   (declare (ignore copy))
 203   (let* ((element-type-spec (second (type-expand-to 'gslist type-spec)))
 204          (to-alien (translate-to-alien element-type-spec 'element t)))
 205     `(let ((gslist (make-pointer 0)))
 206        (dolist (element (reverse ,list) gslist)
 207          (setq gslist (gslist-prepend gslist ,to-alien ,element-type-spec))))))
 208
 209 (deftype-method translate-from-alien
 210     gslist (type-spec gslist &optional (alloc :reference))
 211   (let ((element-type-spec (second (type-expand-to 'gslist type-spec))))
 212     `(let ((gslist ,gslist)
 213            (list nil))
 214        (do ((tmp gslist (glist-next tmp)))
 215            ((null-pointer-p tmp))
 216          (push
 217           ,(translate-from-alien
 218             element-type-spec `(glist-data tmp ,element-type-spec) alloc)
 219           list))
 220        ,(when (eq alloc :reference)
 221           '(gslist-free gslist))
 222        (nreverse list))))
 223
 224 (deftype-method cleanup-alien gslist (type-spec gslist &optional copied)
 225   (declare (ignore copied))
 226   (let* ((element-type-spec (second (type-expand-to 'gslist type-spec)))
 227          (alien-type-spec (translate-type-spec element-type-spec)))
 228     `(let ((gslist ,gslist))
 229        (unless (null-pointer-p gslist)
 230          ,(when (eq alien-type-spec 'system-area-pointer)
 231             `(do ((tmp gslist (glist-next tmp)))
 232                  ((null-pointer-p tmp))
 233                ,(cleanup-alien
 234                  element-type-spec `(glist-data tmp ,element-type-spec) t)))
 235          (gslist-free gslist)))))
 236
 237
 238
 239 ;;; Vector
 240
 241 (deftype-method translate-type-spec vector (type-spec)
 242   (declare (ignore type-spec))
 243   (translate-type-spec 'pointer))
 244
 245 (deftype-method size-of vector (type-spec)
 246   (declare (ignore type-spec))
 247   (size-of 'pointer))
 248
 249 (deftype-method translate-to-alien vector (type-spec vector &optional copy)
 250   (declare (ignore copy))
 251   (destructuring-bind (element-type &optional (length '*))
 252       (cdr (type-expand-to 'vector type-spec))
 253     (let ((element-size (size-of element-type)))
 254       `(let ((vector ,vector))
 255          (let ((c-vector
 256                 (allocate-memory
 257                  ,(if (eq length '*)
 258                       `(* ,element-size (length vector))
 259                     (* element-size length)))))
 260            (dotimes (i ,(if (eq length '*) '(length vector) length) c-vector)
 261              (setf
 262               (,(sap-ref-fname element-type) c-vector (* i ,element-size))
 263               ,(translate-to-alien element-type '(aref vector i) :copy))))))))
 264
 265 (deftype-method translate-from-alien
 266     vector (type-spec sap &optional (alloc :reference))
 267   (destructuring-bind (element-type &optional (length '*))
 268       (cdr (type-expand-to 'vector type-spec))
 269     (when (eq length '*)
 270       (error "Can't use vectors of variable length as return type"))
 271     (let ((element-size (size-of element-type)))
 272       `(let ((sap ,sap)
 273              (vector (make-array ,length :element-type ',element-type)))
 274          (dotimes (i ,length vector)
 275            (setf
 276             (aref vector i)
 277             ,(translate-to-alien
 278               element-type
 279               `(,(sap-ref-fname element-type) sap (* i ,element-size))
 280               alloc)))))))
 281
 282
 283 (deftype-method cleanup-alien vector (type-spec sap &optional copied)
 284   (declare (ignore type-spec copied))
 285   ;; The individual elements also have to be cleaned up to avoid memory leaks,
 286   ;; but this is currently not possible because we can't always tell the
 287   ;; length of the vector
 288   `(deallocate-memory ,sap))