From 17d75d6f798e391e5b909d34ddb176532e5b3c89 Mon Sep 17 00:00:00 2001 Message-Id: <17d75d6f798e391e5b909d34ddb176532e5b3c89.1716547986.git.mdw@distorted.org.uk> From: Mark Wooding Date: Mon, 12 Nov 2001 22:26:56 +0000 Subject: [PATCH] added some preliminary unicode support Organization: Straylight/Edgeware From: espen --- glib/gutils.lisp | 36 +++++++++++++++++++++++++++++++++++- 1 file changed, 35 insertions(+), 1 deletion(-) diff --git a/glib/gutils.lisp b/glib/gutils.lisp index 2558973..7fd00b9 100644 --- a/glib/gutils.lisp +++ b/glib/gutils.lisp @@ -15,7 +15,7 @@ ;; 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.9 2001-10-21 16:53:13 espen Exp $ +;; $Id: gutils.lisp,v 1.10 2001-11-12 22:26:56 espen Exp $ (in-package "KERNEL") @@ -165,3 +165,37 @@ (defun plist-remove (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))) -- [mdw]