From: espen Date: Wed, 27 Oct 2004 14:52:31 +0000 (+0000) Subject: Renamed to utils.lisp X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/commitdiff_plain/4532d3d3c9bfbdeab0ea00018d30cdde8104df47 Renamed to utils.lisp --- diff --git a/glib/gutils.lisp b/glib/gutils.lisp deleted file mode 100644 index 7fd00b9..0000000 --- a/glib/gutils.lisp +++ /dev/null @@ -1,201 +0,0 @@ -;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 1999-2000 Espen S. Johnsen -;; -;; 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)))