1 ;; Common Lisp bindings for GTK+ v1.2.x
2 ;; Copyright (C) 1999 Espen S. Johnsen <espejohn@online.no>
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.
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.
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
18 ;; $Id: glib.lisp,v 1.2 2000-08-15 23:25:18 espen Exp $
25 ;;;; Memory management
27 (define-foreign ("g_malloc0" allocate-memory) () pointer
30 (define-foreign ("g_realloc" reallocate-memory) () pointer
34 (define-foreign ("g_free" deallocate-memory) () nil
37 (defun copy-memory (from length &optional (to (allocate-memory length)))
38 (kernel:system-area-copy from 0 to 0 (* 8 length))
45 (deftype glist () 'pointer)
46 (deftype double-list (type) `(or (null (cons ,type list))))
49 (define-foreign ("g_list_append" %glist-append) () glist
53 (defmacro glist-append (glist value type-spec)
54 (ecase (first (mklist (translate-type-spec type-spec)))
55 (unsigned `(%glist-append ,glist ,value))
56 ; (signed `(%glist-append ,glist (signed-to-unsigned ,value)))
57 (system-area-pointer `(%glist-append ,glist (system:sap-int ,value)))))
60 (defmacro glist-data (glist type-spec)
61 (ecase (first (mklist (translate-type-spec type-spec)))
62 (unsigned `(sap-ref-unsigned ,glist 0))
63 (signed `(sap-ref-signed ,glist 0))
64 (system-area-pointer `(sap-ref-sap ,glist 0))))
67 (defun glist-next (glist)
68 (unless (null-pointer-p glist)
69 (sap-ref-sap glist +size-of-sap+)))
72 (define-foreign ("g_list_free" glist-free) () nil
76 (deftype-method translate-type-spec double-list (type-spec)
77 (declare (ignore type-spec))
80 (deftype-method translate-to-alien double-list (type-spec list &optional copy)
81 (declare (ignore copy))
82 (let* ((element-type-spec (second (type-expand-to 'double-list type-spec)))
83 (to-alien (translate-to-alien element-type-spec 'element t)))
84 `(let ((glist (make-pointer 0)))
85 (dolist (element ,list glist)
86 (setq glist (glist-append glist ,to-alien ,element-type-spec))))))
90 double-list (type-spec glist &optional (alloc :dynamic))
91 (let ((element-type-spec (second (type-expand-to 'double-list type-spec))))
94 (do ((tmp glist (glist-next tmp)))
95 ((null-pointer-p tmp))
97 ,(translate-from-alien
98 element-type-spec `(glist-data tmp ,element-type-spec) alloc)
100 ,(when (eq alloc :dynamic)
104 (deftype-method cleanup-alien double-list (type-spec glist &optional copied)
105 (declare (ignore copied))
106 (let* ((element-type-spec (second (type-expand-to 'double-list type-spec)))
107 (alien-type-spec (translate-type-spec element-type-spec)))
108 `(let ((glist ,glist))
109 (unless (null-pointer-p glist)
110 ,(when (eq alien-type-spec 'system-area-pointer)
111 `(do ((tmp glist (glist-next tmp)))
112 ((null-pointer-p tmp))
114 element-type-spec `(glist-data tmp ,element-type-spec) t)))
115 (glist-free glist)))))
121 (define-foreign ("g_array_new" %array-new) () garray
122 (zero-terminated boolean)
124 (element-size unsigned-int))
126 (defun array-new (&key zero-terminated clear (element-size 4) initial-contents)
127 (let ((array (%array-new zero-terminated clear element-size)))
128 (when initial-contents
129 (dolist (element initial-contents)
130 (array-append array element)))
133 (define-foreign ("g_array_free" %array-free) () none
135 (free-segment boolean))
137 (defun array-free (array &optional free-data (free-segment t))
139 (dotimes (i (array-get-size array))
140 (free (array-get-pointer array i))))
141 (%array-free array free-segment))
143 (defmacro with-array (binding &body body)
144 (let ((array (gensym)))
145 (destructuring-bind (var &rest args
146 &key (free-contents nil) (free-segment t)
149 (remf args :free-contents)
150 (remf args :free-segment)
151 `(let* ((,array (array-new ,@args))
152 (,var (array-get-data ,array)))
155 (array-free ,array ,free-contents ,free-segment))))))
158 (define-foreign ("g_array_insert_int" array-insert-int) () garray
163 (defun array-insert-value (array index value)
165 (null (array-insert-int array index 0))
166 (integer (array-insert-int array index value))
167 (string (array-insert-int array index (sap-int (gforeign::pointer-to-sap (%strdup value)))))
168 (pointer (array-insert-int array index (sap-int (gforeign::pointer-to-sap value))))))
170 (defun array-prepend (array value)
171 (array-insert-value array 0 value))
173 (defun array-append (array value)
174 (array-insert-value array (array-get-size array) value))
177 (define-foreign ("g_array_get_int" array-get-int) () int
179 (index unsigned-int))
181 (defun array-get-pointer (array index)
182 (gforeign::sap-to-pointer (int-sap (array-get-int array index))))
185 (define-foreign ("g_array_get_data" array-get-data) () pointer
188 (define-foreign ("g_array_set_size" array-set-size) () garray
193 (define-foreign ("g_array_get_size" array-get-size) () int