1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
4 ;; Permission is hereby granted, free of charge, to any person obtaining
5 ;; a copy of this software and associated documentation files (the
6 ;; "Software"), to deal in the Software without restriction, including
7 ;; without limitation the rights to use, copy, modify, merge, publish,
8 ;; distribute, sublicense, and/or sell copies of the Software, and to
9 ;; permit persons to whom the Software is furnished to do so, subject to
10 ;; the following conditions:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
23 ;; $Id: utils.lisp,v 1.5 2005-04-23 16:48:51 espen Exp $
28 (defun type-expand-1 (form)
29 (let ((def (cond ((symbolp form)
30 #+cmu(kernel::info type expander form)
31 #+sbcl(sb-impl::info :type :expander form))
32 ((and (consp form) (symbolp (car form)))
33 #+cmu(kernel::info type expander (car form))
34 #+sbcl(sb-impl::info :type :expander (car form)))
37 (values (funcall def (if (consp form) form (list form))) t)
41 (defun type-expand-to (type form)
42 (labels ((expand (form0)
43 (if (eq (first (mklist form0)) type)
45 (multiple-value-bind (expanded-form expanded-p)
48 (expand expanded-form)
49 (error "~A can not be expanded to ~A" form type))))))
52 (defmacro with-gc-disabled (&body body)
53 #+cmu`(system:without-gcing ,@body)
54 #+sbcl`(sb-impl::without-gcing ,@body))
57 (if (and obj (atom obj)) (list obj) obj))
60 (and (symbolp obj) (not (member obj '(t nil)))))
62 (defun all-equal (&rest objects)
67 (equal (first objects) (second objects))
68 (apply #'all-equal (rest objects)))))
70 (defun neq (obj1 obj2)
73 (defmacro return-if (form)
74 (let ((result (make-symbol "RESULT")))
75 `(let ((,result ,form))
79 (defun make-pointer (address)
82 (defun null-pointer-p (pointer)
83 (zerop (sap-int pointer)))
86 (defmacro when-bind ((var expr) &body body)
92 (defmacro assoc-ref (key alist &key (test #'eq))
93 `(cdr (assoc ,key ,alist :test ,test)))
96 (defmacro assoc-lref (key alist &key (test #'eq))
97 `(cadr (assoc ,key ,alist :test ,test)))
100 (defun assoc-rem (key alist &key (test #'eq))
101 (remove-if #'(lambda (element) (funcall test key (car element))) alist))
104 (defun assoc-delete (key alist &key (test #'eq))
105 (delete-if #'(lambda (element) (funcall test key (car element))) alist))
108 (defun funcallable (object)
113 (defun intersection-p (list1 list2 &key (test #'eq))
114 (dolist (obj list1 nil)
115 (when (member obj list2 :test test)
116 (return-from intersection-p t))))
119 (defun split-string (string delimiter)
120 (declare (simple-string string) (character delimiter))
121 (let ((pos (position delimiter string)))
125 (subseq string 0 pos)
126 (split-string (subseq string (1+ pos)) delimiter)))))
128 (defun split-string-if (string predicate)
129 (declare (simple-string string))
130 (let ((pos (position-if predicate string :start 1)))
134 (subseq string 0 pos)
135 (split-string-if (subseq string pos) predicate)))))
137 (defun concatenate-strings (strings &optional delimiter)
138 (if (not (rest strings))
143 (if delimiter (string delimiter) "")
144 (concatenate-strings (rest strings) delimiter))))
146 (defun string-prefix-p (prefix string)
148 (>= (length string) (length prefix))
149 (string= prefix string :end2 (length prefix))))
151 (defun get-all (plist property)
152 (multiple-value-bind (property value tail)
153 (get-properties plist (list property))
155 (cons value (get-all (cddr tail) property)))))
157 (defun plist-remove (plist property)
159 (if (eq (first plist) property)
160 (plist-remove (cddr plist) property)
162 (first plist) (second plist) (plist-remove (cddr plist) property)))))
167 (defun utf-8-encode (code)
168 (labels ((encode-bytes (bit)
172 #x80 (byte 7 6) (ldb (byte bit (- bit 6)) code))
173 (encode-bytes (- bit 6)))))
174 (encode-string (length)
175 (map 'string #'code-char
178 (mask-field (byte 7 (- 7 length)) #xFF)
179 (byte 7 (- 6 length))
180 (ldb (byte (+ (* length 6) 6) (* length 6)) code))
181 (encode-bytes (* length 6))))))
183 ((< code #x80) (string (code-char code)))
184 ((< code #x800) (encode-string 1))
185 ((< code #x10000) (encode-string 2))
186 ((< code #x200000) (encode-string 3))
187 ((< code #x4000000) (encode-string 4))
188 ((< code #x80000000) (encode-string 5))
189 (t (error "Invalid char code ~A" code)))))
192 (defun latin1-to-unicode (string)
194 #'(lambda (str1 str2)
195 (concatenate 'string str1 str2))
196 (map 'list #'(lambda (char) (utf-8-encode (char-code char))) string)))