chiark - git - mdw - clg/blob - glib/utils.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   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:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  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.
  22
  23 ;; $Id: utils.lisp,v 1.5 2005-04-23 16:48:51 espen Exp $
  24
  25
  26 (in-package "GLIB")
  27
  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)))
  35                    (t nil))))
  36     (if def
  37         (values (funcall def (if (consp form) form (list form))) t)
  38       (values form nil))))
  39
  40
  41 (defun type-expand-to (type form)
  42   (labels ((expand (form0)
  43              (if (eq (first (mklist form0)) type)
  44                  form0
  45                (multiple-value-bind (expanded-form expanded-p)
  46                    (type-expand-1 form0)
  47                  (if expanded-p
  48                      (expand expanded-form)
  49                    (error "~A can not be expanded to ~A" form type))))))
  50     (expand form)))
  51
  52 (defmacro with-gc-disabled (&body body)
  53   #+cmu`(system:without-gcing ,@body)
  54   #+sbcl`(sb-impl::without-gcing ,@body))
  55
  56 (defun mklist (obj)
  57   (if (and obj (atom obj)) (list obj) obj))
  58
  59 (defun namep (obj)
  60   (and (symbolp obj) (not (member obj '(t nil)))))
  61
  62 (defun all-equal (&rest objects)
  63   (or
  64    (null objects)
  65    (null (rest objects))
  66    (and
  67     (equal (first objects) (second objects))
  68     (apply #'all-equal (rest objects)))))
  69
  70 (defun neq (obj1 obj2)
  71   (not (eq obj1 obj2)))
  72
  73 (defmacro return-if (form)
  74   (let ((result (make-symbol "RESULT")))
  75     `(let ((,result ,form))
  76        (when ,result
  77          (return ,result)))))
  78
  79 (defun make-pointer (address)
  80   (int-sap address))
  81
  82 (defun null-pointer-p (pointer)
  83   (zerop (sap-int pointer)))
  84
  85
  86 (defmacro when-bind ((var expr) &body body)
  87   `(let ((,var ,expr))
  88      (when ,var
  89        ,@body)))
  90
  91
  92 (defmacro assoc-ref (key alist &key (test #'eq))
  93   `(cdr (assoc ,key ,alist :test ,test)))
  94
  95
  96 (defmacro assoc-lref (key alist &key (test #'eq))
  97   `(cadr (assoc ,key ,alist :test ,test)))
  98
  99
 100 (defun assoc-rem (key alist &key (test #'eq))
 101   (remove-if #'(lambda (element) (funcall test key (car element))) alist))
 102
 103
 104 (defun assoc-delete (key alist &key (test #'eq))
 105   (delete-if #'(lambda (element) (funcall test key (car element))) alist))
 106
 107
 108 (defun funcallable (object)
 109   (if (consp object)
 110       (fdefinition object)
 111     object))
 112
 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))))
 117
 118
 119 (defun split-string (string delimiter)
 120   (declare (simple-string string) (character delimiter))
 121   (let ((pos (position delimiter string)))
 122    (if (not pos)
 123         (list string)
 124       (cons
 125        (subseq string 0 pos)
 126        (split-string (subseq string (1+ pos)) delimiter)))))
 127
 128 (defun split-string-if (string predicate)
 129   (declare (simple-string string))
 130   (let ((pos (position-if predicate string :start 1)))
 131     (if (not pos)
 132         (list string)
 133       (cons
 134        (subseq string 0 pos)
 135        (split-string-if (subseq string pos) predicate)))))
 136
 137 (defun concatenate-strings (strings &optional delimiter)
 138   (if (not (rest strings))
 139       (first strings)
 140     (concatenate
 141      'string
 142      (first strings)
 143      (if delimiter (string delimiter) "")
 144      (concatenate-strings (rest strings) delimiter))))
 145
 146 (defun string-prefix-p (prefix string)
 147   (and
 148    (>= (length string) (length prefix))
 149    (string= prefix string :end2 (length prefix))))
 150
 151 (defun get-all (plist property)
 152   (multiple-value-bind (property value tail)
 153       (get-properties plist (list property))
 154     (when tail
 155       (cons value (get-all (cddr tail) property)))))
 156
 157 (defun plist-remove (plist property)
 158   (when plist
 159     (if (eq (first plist) property)
 160         (plist-remove (cddr plist) property)
 161       (list*
 162        (first plist) (second plist) (plist-remove (cddr plist) property)))))
 163
 164
 165 ;;;
 166
 167 (defun utf-8-encode (code)
 168   (labels ((encode-bytes (bit)
 169              (unless (zerop bit)
 170                (cons
 171                 (deposit-field
 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
 176               (cons
 177                (deposit-field
 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))))))
 182     (cond
 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)))))
 190
 191
 192 (defun latin1-to-unicode (string)
 193   (reduce
 194    #'(lambda (str1 str2)
 195        (concatenate 'string str1 str2))
 196    (map 'list #'(lambda (char) (utf-8-encode (char-code char))) string)))