gutils.lisp renamed

[clg] / glib / gutils.lisp

;; Common Lisp bindings for GTK+ v2.0
;; Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.no>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

;; $Id: gutils.lisp,v 1.10 2001-11-12 22:26:56 espen Exp $


(in-package "KERNEL")

(defun type-expand-1 (form)
  (let ((def (cond ((symbolp form)
		    (info type expander form))
		   ((and (consp form) (symbolp (car form)))
		    (info type expander (car form)))
		   (t nil))))
    (if def
	(values (funcall def (if (consp form) form (list form))) t)
      (values form nil))))


(in-package "GLIB")

(defun type-expand-to (type form)
  (labels ((expand (form0)
             (if (eq (first (mklist form0)) type)
		 form0
	       (multiple-value-bind (expanded-form expanded-p)
		   (type-expand-1 form0)
		 (if expanded-p
		     (expand expanded-form)
		   (error "~A can not be expanded to ~A" form type))))))
    (expand form)))

(defmacro with-gc-disabled (&body body)
  (let ((gc-inhibit (make-symbol "GC-INHIBIT")))
    `(progn
       (let ((,gc-inhibit lisp::*gc-inhibit*))
	 (ext:gc-off)
	 	 (unwind-protect
	     ,@body
	   (unless ,gc-inhibit
	     (ext:gc-on)))))))

(defun mklist (obj)
  (if (atom obj) (list obj) obj))

(defun namep (obj)
  (and (symbolp obj) (not (member obj '(t nil)))))

(defun all-equal (&rest objects)
  (or
   (null objects)
   (null (rest objects))
   (and
    (equal (first objects) (second objects))
    (apply #'all-equal (rest objects)))))

(defun neq (obj1 obj2)
  (not (eq obj1 obj2)))

(defmacro return-if (form)
  (let ((result (make-symbol "RESULT")))
    `(let ((,result ,form))
       (when ,result
	 (return ,result)))))

(defun make-pointer (address)
  (int-sap address))
  
(defun null-pointer-p (pointer)
  (zerop (sap-int pointer)))
  

(defmacro when-bind ((var expr) &body body)
  `(let ((,var ,expr))
     (when ,var
       ,@body)))


(defmacro assoc-ref (key alist &key (test #'eq))
  `(cdr (assoc ,key ,alist :test ,test)))


(defmacro assoc-lref (key alist &key (test #'eq))
  `(cadr (assoc ,key ,alist :test ,test)))


(defun assoc-rem (key alist &key (test #'eq))
  (remove-if #'(lambda (element) (funcall test key (car element))) alist))


(defun assoc-delete (key alist &key (test #'eq))
  (delete-if #'(lambda (element) (funcall test key (car element))) alist))


(defun funcallable (object)
  (if (consp object)
      (fdefinition object)
    object))

(defun intersection-p (list1 list2 &key (test #'eq))
  (dolist (obj list1 nil)
    (when (member obj list2 :test test)
      (return-from intersection-p t))))


(defun split-string (string delimiter)
  (declare (simple-string string) (character delimiter))
  (check-type string string)
  (check-type delimiter character)
  (let ((pos (position delimiter string)))
   (if (not pos)
        (list string)
      (cons
       (subseq string 0 pos)
       (split-string (subseq string (1+ pos)) delimiter)))))

(defun split-string-if (string predicate)
  (declare (simple-string string))
  (check-type string string)
  (check-type predicate (or symbol function))
  (let ((pos (position-if predicate string :start 1)))
    (if (not pos)
        (list string)
      (cons
       (subseq string 0 pos)
       (split-string-if (subseq string pos) predicate)))))

(defun concatenate-strings (strings &optional delimiter)
  (if (not (rest strings))
      (first strings)
    (concatenate
     'string
     (first strings)
     (if delimiter (string delimiter) "")
     (concatenate-strings (rest strings) delimiter))))

(defun string-prefix-p (prefix string)
  (and
   (>= (length string) (length prefix))
   (string= prefix string :end2 (length prefix))))

(defun get-all (plist property)
  (multiple-value-bind (property value tail)
      (get-properties plist (list property))
    (when tail
      (cons value (get-all (cddr tail) property)))))

(defun plist-remove (plist property)
  (when plist
    (if (eq (first plist) property)
	(plist-remove (cddr plist) property)
      (list*
       (first plist) (second plist) (plist-remove (cddr plist) property)))))


;;;

(defun utf-8-encode (code)
  (labels ((encode-bytes (bit)
             (unless (zerop bit)
	       (cons
		(deposit-field 
                 #x80 (byte 7 6) (ldb (byte bit (- bit 6)) code))
		(encode-bytes (- bit 6)))))
           (encode-string (length)
             (map 'string #'code-char
              (cons
               (deposit-field
	        (mask-field (byte 7 (- 7 length)) #xFF)
		(byte 7 (- 6 length))
		(ldb (byte (+ (* length 6) 6) (* length 6)) code))
	       (encode-bytes (* length 6))))))
    (cond
     ((< code #x80) (string (code-char code)))
     ((< code #x800) (encode-string 1))
     ((< code #x10000) (encode-string 2))
     ((< code #x200000) (encode-string 3)) 
     ((< code #x4000000) (encode-string 4))
     ((< code #x80000000) (encode-string 5))
     (t (error "Invalid char code ~A" code)))))


(defun latin1-to-unicode (string)
  (reduce
   #'(lambda (str1 str2)
       (concatenate 'string str1 str2))
   (map 'list #'(lambda (char) (utf-8-encode (char-code char))) string)))