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.5 2000-08-23 21:36:44 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 (defvar *quark-from-object* (make-hash-table))
  50 (defvar *quark-to-object* (make-hash-table))
  51
  52 (defun quark-from-object (object &key (test #'eq))
  53   (let ((hash-code (sxhash object)))
  54     (or
  55      (assoc-ref object (gethash hash-code *quark-from-object*) :test test)
  56      (let ((quark (%quark-get-reserved)))
  57        (setf
  58         (gethash hash-code *quark-from-object*)
  59         (append
  60          (gethash hash-code *quark-from-object*)
  61          (list (cons object quark))))
  62        (setf (gethash quark *quark-to-object*) object)
  63        quark))))
  64
  65 (defun quark-to-object (quark)
  66   (gethash quark *quark-to-object*))
  67
  68 (defun remove-quark (quark)
  69   (let* ((object (gethash quark *quark-to-object*))
  70          (hash-code (sxhash object)))
  71     (remhash quark *quark-to-object*)
  72     (unless (setf
  73              (gethash hash-code *quark-from-object*)
  74              (assoc-delete object (gethash hash-code *quark-from-object*)))
  75       (remhash hash-code *quark-from-object*))))
  76
  77
  78
  79 ;;;; Linked list
  80
  81 (deftype glist () 'pointer)
  82 (deftype double-list (type) `(or (null (cons ,type list))))
  83
  84
  85 (define-foreign ("g_list_append" %glist-append) () glist
  86   (glist glist)
  87   (data unsigned))
  88
  89 (defmacro glist-append (glist value type-spec)
  90   (ecase (first (mklist (translate-type-spec type-spec)))
  91     (unsigned `(%glist-append ,glist ,value))
  92 ;    (signed `(%glist-append ,glist (signed-to-unsigned ,value)))
  93     (system-area-pointer `(%glist-append ,glist (system:sap-int ,value)))))
  94
  95
  96 (defmacro glist-data (glist type-spec)
  97   (ecase (first (mklist (translate-type-spec type-spec)))
  98     (unsigned `(sap-ref-unsigned ,glist 0))
  99     (signed `(sap-ref-signed ,glist 0))
 100     (system-area-pointer `(sap-ref-sap ,glist 0))))
 101
 102
 103 (defun glist-next (glist)
 104   (unless (null-pointer-p glist)
 105     (sap-ref-sap glist +size-of-sap+)))
 106
 107
 108 (define-foreign ("g_list_free" glist-free) () nil
 109   (glist pointer))
 110
 111
 112 (deftype-method translate-type-spec double-list (type-spec)
 113   (declare (ignore type-spec))
 114   'system-area-pointer)
 115
 116 (deftype-method translate-to-alien double-list (type-spec list &optional copy)
 117   (declare (ignore copy))
 118   (let* ((element-type-spec (second (type-expand-to 'double-list type-spec)))
 119          (to-alien (translate-to-alien element-type-spec 'element t)))
 120     `(let ((glist (make-pointer 0)))
 121        (dolist (element ,list glist)
 122          (setq glist (glist-append glist ,to-alien ,element-type-spec))))))
 123
 124 (deftype-method
 125     translate-from-alien
 126     double-list (type-spec glist &optional (alloc :reference))
 127   (let ((element-type-spec (second (type-expand-to 'double-list type-spec))))
 128     `(let ((glist ,glist)
 129            (list nil))
 130        (do ((tmp glist (glist-next tmp)))
 131            ((null-pointer-p tmp))
 132          (push
 133           ,(translate-from-alien
 134             element-type-spec `(glist-data tmp ,element-type-spec) alloc)
 135           list))
 136        ,(when (eq alloc :reference)
 137           '(glist-free glist))
 138        (nreverse list))))
 139
 140 (deftype-method cleanup-alien double-list (type-spec glist &optional copied)
 141   (declare (ignore copied))
 142   (let* ((element-type-spec (second (type-expand-to 'double-list type-spec)))
 143          (alien-type-spec (translate-type-spec element-type-spec)))
 144     `(let ((glist ,glist))
 145        (unless (null-pointer-p glist)
 146          ,(when (eq alien-type-spec 'system-area-pointer)
 147             `(do ((tmp glist (glist-next tmp)))
 148                  ((null-pointer-p tmp))
 149                ,(cleanup-alien
 150                  element-type-spec `(glist-data tmp ,element-type-spec) t)))
 151          (glist-free glist)))))
 152
 153
 154
 155 ;;; Array
 156 #|
 157 (define-foreign ("g_array_new" %array-new) () garray
 158   (zero-terminated boolean)
 159   (clear boolean)
 160   (element-size unsigned-int))
 161
 162 (defun array-new (&key zero-terminated clear (element-size 4) initial-contents)
 163   (let ((array (%array-new zero-terminated clear element-size)))
 164     (when initial-contents
 165       (dolist (element initial-contents)
 166         (array-append array element)))
 167     array))
 168
 169 (define-foreign ("g_array_free" %array-free) () none
 170   (array garray)
 171   (free-segment boolean))
 172
 173 (defun array-free (array &optional free-data (free-segment t))
 174   (when free-data
 175     (dotimes (i (array-get-size array))
 176       (free (array-get-pointer array i))))
 177   (%array-free array free-segment))
 178
 179 (defmacro with-array (binding &body body)
 180   (let ((array (gensym)))
 181     (destructuring-bind (var &rest args
 182                          &key (free-contents nil) (free-segment t)
 183                          &allow-other-keys )
 184         binding
 185       (remf args :free-contents)
 186       (remf args :free-segment)
 187       `(let* ((,array (array-new ,@args))
 188               (,var (array-get-data ,array)))
 189          (unwind-protect
 190              ,@body
 191            (array-free ,array ,free-contents ,free-segment))))))
 192
 193 ;; cl-gtk.c
 194 (define-foreign ("g_array_insert_int" array-insert-int) () garray
 195   (array garray)
 196   (index unsigned-int)
 197   (value int))
 198
 199 (defun array-insert-value (array index value)
 200   (etypecase value
 201     (null (array-insert-int array index 0))
 202     (integer (array-insert-int array index value))
 203     (string (array-insert-int array index (sap-int (gforeign::pointer-to-sap (%strdup value)))))
 204     (pointer (array-insert-int array index (sap-int (gforeign::pointer-to-sap value))))))
 205
 206 (defun array-prepend (array value)
 207   (array-insert-value array 0 value))
 208
 209 (defun array-append (array value)
 210   (array-insert-value array (array-get-size array) value))
 211
 212 ;; cl-gtk.c
 213 (define-foreign ("g_array_get_int" array-get-int) () int
 214   (array garray)
 215   (index unsigned-int))
 216
 217 (defun array-get-pointer (array index)
 218   (gforeign::sap-to-pointer (int-sap (array-get-int array index))))
 219
 220 ;; cl-gtk.c
 221 (define-foreign ("g_array_get_data" array-get-data) () pointer
 222   (array garray))
 223
 224 (define-foreign ("g_array_set_size" array-set-size) () garray
 225   (array garray)
 226   (size unsigned-int))
 227
 228 ;; cl-gtk.c
 229 (define-foreign ("g_array_get_size" array-get-size) () int
 230   (array garray))
 231 |#